-- Copyright 2022 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
module Derive.Parse.Ky (
    Ky(..), Loaded(..)
    , Definitions(..), Definition
    , load_ky
    , get_ky
    -- ** types
    , Expr(..), Call(..), Term(..), Var(..)
#ifdef TESTING
    , module Derive.Parse.Ky
#endif
) where
import           Control.Applicative (many)
import qualified Control.Monad.Except as Except
import qualified Data.Attoparsec.Text as A
import qualified Data.Char as Char
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO

import           System.FilePath ((</>))

import qualified Util.Exceptions as Exceptions
import qualified Util.Lists as Lists
import qualified Util.Maps as Maps
import qualified Util.Parse
import qualified Util.ParseText as ParseText

import qualified Derive.DeriveT as DeriveT
import qualified Derive.Expr as Expr
import qualified Derive.Parse as Parse
import qualified Derive.Parse.Instruments as Instruments
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Symbols as Symbols

import qualified Ui.Id as Id
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global


type Error = Text
-- | Ky code.  For the whole file or whole sections, not fragments or lines.
type Code = Text

-- | A parsed .ky file
data Ky a = Ky {
    forall a. Ky a -> Definitions
ky_definitions :: Definitions
    , forall a. Ky a -> [a]
ky_imports :: [a]
    -- | Nothing if there is no instrument section.
    , forall a. Ky a -> Maybe [Allocation]
ky_instruments :: Maybe [Instruments.Allocation]
    } deriving (Line -> Ky a -> ShowS
forall a. Show a => Line -> Ky a -> ShowS
forall a. Show a => [Ky a] -> ShowS
forall a. Show a => Ky a -> String
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ky a] -> ShowS
$cshowList :: forall a. Show a => [Ky a] -> ShowS
show :: Ky a -> String
$cshow :: forall a. Show a => Ky a -> String
showsPrec :: Line -> Ky a -> ShowS
$cshowsPrec :: forall a. Show a => Line -> Ky a -> ShowS
Show)

instance Semigroup (Ky a) where
    Ky Definitions
a1 [a]
b1 Maybe [Allocation]
c1 <> :: Ky a -> Ky a -> Ky a
<> Ky Definitions
a2 [a]
b2 Maybe [Allocation]
c2 = forall a. Definitions -> [a] -> Maybe [Allocation] -> Ky a
Ky (Definitions
a1forall a. Semigroup a => a -> a -> a
<>Definitions
a2) ([a]
b1forall a. Semigroup a => a -> a -> a
<>[a]
b2) (Maybe [Allocation]
c1forall a. Semigroup a => a -> a -> a
<>Maybe [Allocation]
c2)
instance Monoid (Ky a) where
    mempty :: Ky a
mempty = forall a. Definitions -> [a] -> Maybe [Allocation] -> Ky a
Ky forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    mappend :: Ky a -> Ky a -> Ky a
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | Record a loaded .ky file, with its path and content.
-- A path of "" is used for the code directly in the UiConfig.
data Loaded = Loaded !FilePath !Code
    deriving (Loaded -> Loaded -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Loaded -> Loaded -> Bool
$c/= :: Loaded -> Loaded -> Bool
== :: Loaded -> Loaded -> Bool
$c== :: Loaded -> Loaded -> Bool
Eq, Line -> Loaded -> ShowS
[Loaded] -> ShowS
Loaded -> String
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Loaded] -> ShowS
$cshowList :: [Loaded] -> ShowS
show :: Loaded -> String
$cshow :: Loaded -> String
showsPrec :: Line -> Loaded -> ShowS
$cshowsPrec :: Line -> Loaded -> ShowS
Show)
-- | A requested import.  Path to .ky file, .ky files it imports.
data Import = Import !FilePath !String
    deriving (Import -> Import -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Import -> Import -> Bool
$c/= :: Import -> Import -> Bool
== :: Import -> Import -> Bool
$c== :: Import -> Import -> Bool
Eq, Line -> Import -> ShowS
[Import] -> ShowS
Import -> String
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Import] -> ShowS
$cshowList :: [Import] -> ShowS
show :: Import -> String
$cshow :: Import -> String
showsPrec :: Line -> Import -> ShowS
$cshowsPrec :: Line -> Import -> ShowS
Show)

-- | This is a mirror of 'Derive.Library', but with expressions instead of
-- calls.  (generators, transformers)
data Definitions = Definitions {
    Definitions -> ([Definition], [Definition])
def_note :: !([Definition], [Definition])
    , Definitions -> ([Definition], [Definition])
def_control :: !([Definition], [Definition])
    , Definitions -> ([Definition], [Definition])
def_pitch :: !([Definition], [Definition])
    , Definitions -> [Definition]
def_val :: ![Definition]
    , Definitions -> [(Instrument, Instrument)]
def_aliases :: ![(ScoreT.Instrument, ScoreT.Instrument)]
    } deriving (Line -> Definitions -> ShowS
[Definitions] -> ShowS
Definitions -> String
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Definitions] -> ShowS
$cshowList :: [Definitions] -> ShowS
show :: Definitions -> String
$cshow :: Definitions -> String
showsPrec :: Line -> Definitions -> ShowS
$cshowsPrec :: Line -> Definitions -> ShowS
Show)

instance Semigroup Definitions where
    <> :: Definitions -> Definitions -> Definitions
(<>)    (Definitions ([Definition]
a1, [Definition]
b1) ([Definition]
c1, [Definition]
d1) ([Definition]
e1, [Definition]
f1) [Definition]
g1 [(Instrument, Instrument)]
h1)
            (Definitions ([Definition]
a2, [Definition]
b2) ([Definition]
c2, [Definition]
d2) ([Definition]
e2, [Definition]
f2) [Definition]
g2 [(Instrument, Instrument)]
h2) =
        ([Definition], [Definition])
-> ([Definition], [Definition])
-> ([Definition], [Definition])
-> [Definition]
-> [(Instrument, Instrument)]
-> Definitions
Definitions ([Definition]
a1forall a. Semigroup a => a -> a -> a
<>[Definition]
a2, [Definition]
b1forall a. Semigroup a => a -> a -> a
<>[Definition]
b2) ([Definition]
c1forall a. Semigroup a => a -> a -> a
<>[Definition]
c2, [Definition]
d1forall a. Semigroup a => a -> a -> a
<>[Definition]
d2) ([Definition]
e1forall a. Semigroup a => a -> a -> a
<>[Definition]
e2, [Definition]
f1forall a. Semigroup a => a -> a -> a
<>[Definition]
f2) ([Definition]
g1forall a. Semigroup a => a -> a -> a
<>[Definition]
g2)
            ([(Instrument, Instrument)]
h1forall a. Semigroup a => a -> a -> a
<>[(Instrument, Instrument)]
h2)
instance Monoid Definitions where
    mempty :: Definitions
mempty = ([Definition], [Definition])
-> ([Definition], [Definition])
-> ([Definition], [Definition])
-> [Definition]
-> [(Instrument, Instrument)]
-> Definitions
Definitions ([], []) ([], []) ([], []) [] []
    mappend :: Definitions -> Definitions -> Definitions
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | (defining_file, (Symbol, Expr))
type Definition = (FilePath, (Expr.Symbol, Expr))

-- * parse ky

-- | Parse ky text and load and parse all the files it imports.  'parse_ky'
-- describes the format of the ky file.
load_ky :: [FilePath] -> Code -> IO (Either ParseText.Error (Ky Loaded))
load_ky :: [String] -> Text -> IO (Either Error (Ky Loaded))
load_ky [String]
paths Text
content = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT forall a b. (a -> b) -> a -> b
$ do
    Ky Import
ky <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Error -> Error
ParseText.prefix Text
"<score>: ") forall a b. (a -> b) -> a -> b
$ String -> Text -> Either Error (Ky Import)
parse_ky String
"" Text
content
    [Ky Loaded]
kys <- [String] -> Set String -> [Import] -> ExceptT Error IO [Ky Loaded]
load_ky_file [String]
paths forall a. Set a
Set.empty (forall a. Ky a -> [a]
ky_imports Ky Import
ky)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Ky Import
ky { ky_imports :: [Loaded]
ky_imports = [String -> Text -> Loaded
Loaded String
"" Text
content] } forall a. a -> [a] -> [a]
: [Ky Loaded]
kys

load_ky_file :: [FilePath] -> Set FilePath -> [Import]
    -> Except.ExceptT ParseText.Error IO [Ky Loaded]
load_ky_file :: [String] -> Set String -> [Import] -> ExceptT Error IO [Ky Loaded]
load_ky_file [String]
_ Set String
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
load_ky_file [String]
paths Set String
loaded (Import String
fname String
lib : [Import]
imports)
    | String
lib forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
loaded = forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Bool
otherwise = do
        let prefix :: Text
prefix = String -> Text
txt String
lib forall a. Semigroup a => a -> a -> a
<> Text
": "
        (String
fname, Text
content) <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Error
ParseText.message forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
prefix<>))
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([String] -> String -> String -> IO (Either Text (String, Text))
find_ky [String]
paths String
fname String
lib)
        Ky Import
ky <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Error -> Error
ParseText.prefix Text
prefix) forall a b. (a -> b) -> a -> b
$
            String -> Text -> Either Error (Ky Import)
parse_ky String
fname Text
content
        [Ky Loaded]
kys <- [String] -> Set String -> [Import] -> ExceptT Error IO [Ky Loaded]
load_ky_file [String]
paths (forall a. Ord a => a -> Set a -> Set a
Set.insert String
lib Set String
loaded)
            ([Import]
imports forall a. [a] -> [a] -> [a]
++ forall a. Ky a -> [a]
ky_imports Ky Import
ky)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Ky Import
ky { ky_imports :: [Loaded]
ky_imports = [String -> Text -> Loaded
Loaded String
fname Text
content] } forall a. a -> [a] -> [a]
: [Ky Loaded]
kys

-- | Find the file in the given paths and return its filename and contents.
find_ky :: [FilePath] -> FilePath -> FilePath
    -> IO (Either Error (FilePath, Code))
find_ky :: [String] -> String -> String -> IO (Either Text (String, Text))
find_ky [String]
paths String
from String
fname =
    forall a. Text -> IO (Either Text a) -> IO (Either Text a)
catch_io (String -> Text
txt String
fname) forall a b. (a -> b) -> a -> b
$ forall err a. err -> Maybe a -> Either err a
justErr Text
msg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts (forall a b. (a -> b) -> [a] -> [b]
map (\String
dir -> String -> IO (Maybe (String, Text))
get (String
dir String -> ShowS
</> String
fname)) [String]
paths)
    where
    msg :: Text
msg = Text
"ky file not found: " forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
fname
        forall a. Semigroup a => a -> a -> a
<> (if String
from forall a. Eq a => a -> a -> Bool
== String
"" then Text
"" else Text
" from " forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
from)
        forall a. Semigroup a => a -> a -> a
<> Text
" (searched " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map String -> Text
txt [String]
paths) forall a. Semigroup a => a -> a -> a
<> Text
")"
    get :: String -> IO (Maybe (String, Text))
get String
fn = forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent forall a b. (a -> b) -> a -> b
$ (,) String
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
Text.IO.readFile String
fn

-- | Catch any IO exceptions and put them in Left.
catch_io :: Text -> IO (Either Error a) -> IO (Either Error a)
catch_io :: forall a. Text -> IO (Either Text a) -> IO (Either Text a)
catch_io Text
prefix IO (Either Text a)
io =
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
showt) forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO a -> IO (Either IOError a)
Exceptions.tryIO IO (Either Text a)
io

{- | Parse a ky file.  This file gives a way to define new calls in the
    tracklang language, which is less powerful but more concise than haskell.

    The syntax is a sequence of @import 'path\/to\/file'@ lines followed by
    a sequence of sections.  A section is a @header:@ line followed by
    definitions.  The header determines the type of the calls defined after it,
    e.g.:

    > import 'somelib.ky'
    >
    > note generator:
    > x = y
    >
    > alias:
    > new-inst = source-inst

    Valid headers are @val:@, @(note|control|pitch) (generator|transformer):@,
    or @alias:@.  A line is continued if it is indented, and @--@ comments
    until the end of the line.

    This is similar to the "Derive.Call.Equal" call, but not quite the same:

    - It uses headers for the call type instead of equal's weird sigils.

    - The syntax is different because the arguments to equal are evaluated in
    place, while a file is all quoted by nature.  E.g. a definition @x = a b c@
    is equivalent to an equal @^x = \"(a b c)@.  @x = a@ (no arguments) is
    equivalent to @^x = a@, in that @x@ can take the same arguments as @a@.

    - Calls are defined as "Derive.Call.Macro"s, which means they can include
    $variables, which become arguments to the call.
-}
parse_ky :: FilePath -> Code -> Either ParseText.Error (Ky Import)
parse_ky :: String -> Text -> Either Error (Ky Import)
parse_ky String
fname Text
text = do
    (Text
imports, Map Text [(Line, Text)]
sections) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Error
ParseText.message forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Text, Map Text [(Line, Text)])
checked_sections Text
text
    (Maybe [(Line, Text)]
instrument_section, Map Text [(Line, Text)]
sections) <- forall (m :: * -> *) a. Monad m => a -> m a
return
        ( forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
Instruments.instrument_section Map Text [(Line, Text)]
sections
        , forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
Instruments.instrument_section Map Text [(Line, Text)]
sections
        )
    let extra :: [Text]
extra = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
            forall k a. Map k a -> Set k
Map.keysSet Map Text [(Line, Text)]
sections forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` forall a. Ord a => [a] -> Set a
Set.fromList [Text]
valid_headers
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
extra) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Error
ParseText.message forall a b. (a -> b) -> a -> b
$
            Text
"unknown sections: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
extra
    [String]
imports <- forall a. Parser a -> Text -> Either Error a
ParseText.parse Parser [String]
p_imports Text
imports
    Map Text [(Symbol, Expr)]
parsed <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [(Line, Text)] -> Either Error [(Symbol, Expr)]
parse_section Map Text [(Line, Text)]
sections
    let get :: Text -> [(Symbol, Expr)]
get Text
header = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Text
header Map Text [(Symbol, Expr)]
parsed
        get2 :: Text -> ([(Symbol, Expr)], [(Symbol, Expr)])
get2 Text
kind =
            ( Text -> [(Symbol, Expr)]
get (Text
kind forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
generator)
            , Text -> [(Symbol, Expr)]
get (Text
kind forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
transformer)
            )
    [(Instrument, Instrument)]
aliases <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Maybe (Text, (Line, Line)) -> Text -> Error
ParseText.Error forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Symbol, Expr) -> Either Text (Instrument, Instrument)
parse_alias (Text -> [(Symbol, Expr)]
get Text
alias)
    Maybe [Allocation]
allocs <- case Maybe [(Line, Text)]
instrument_section of
        Maybe [(Line, Text)]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just [(Line, Text)]
lines -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Line, Text) -> Either Error (Maybe Allocation)
parse_instrument [(Line, Text)]
lines
    let add_fname :: [a] -> [(String, a)]
add_fname = forall a b. (a -> b) -> [a] -> [b]
map (String
fname,)
        add_fname2 :: ([a], [a]) -> ([(String, a)], [(String, a)])
add_fname2 = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall {a}. [a] -> [(String, a)]
add_fname forall {a}. [a] -> [(String, a)]
add_fname
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Ky
        { ky_definitions :: Definitions
ky_definitions = Definitions
            { def_note :: ([Definition], [Definition])
def_note = forall {a} {a}. ([a], [a]) -> ([(String, a)], [(String, a)])
add_fname2 forall a b. (a -> b) -> a -> b
$ Text -> ([(Symbol, Expr)], [(Symbol, Expr)])
get2 Text
note
            , def_control :: ([Definition], [Definition])
def_control = forall {a} {a}. ([a], [a]) -> ([(String, a)], [(String, a)])
add_fname2 forall a b. (a -> b) -> a -> b
$ Text -> ([(Symbol, Expr)], [(Symbol, Expr)])
get2 Text
control
            , def_pitch :: ([Definition], [Definition])
def_pitch = forall {a} {a}. ([a], [a]) -> ([(String, a)], [(String, a)])
add_fname2 forall a b. (a -> b) -> a -> b
$ Text -> ([(Symbol, Expr)], [(Symbol, Expr)])
get2 Text
pitch
            , def_val :: [Definition]
def_val = forall {a}. [a] -> [(String, a)]
add_fname forall a b. (a -> b) -> a -> b
$ Text -> [(Symbol, Expr)]
get Text
val
            , def_aliases :: [(Instrument, Instrument)]
def_aliases = [(Instrument, Instrument)]
aliases
            }
        , ky_imports :: [Import]
ky_imports = forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Import
Import String
fname) [String]
imports
        , ky_instruments :: Maybe [Allocation]
ky_instruments = Maybe [Allocation]
allocs
        }
    where
    val :: Text
val = Text
"val"
    note :: Text
note = Text
"note"
    control :: Text
control = Text
"control"
    pitch :: Text
pitch = Text
"pitch"
    generator :: Text
generator = Text
"generator"
    transformer :: Text
transformer = Text
"transformer"
    alias :: Text
alias = Text
"alias"
    valid_headers :: [Text]
valid_headers = Text
val forall a. a -> [a] -> [a]
: Text
alias forall a. a -> [a] -> [a]
:
        [ Text
t1 forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
t2
        | Text
t1 <- [Text
note, Text
control, Text
pitch], Text
t2 <- [Text
generator, Text
transformer]
        ]
    parse_section :: [(Line, Text)] -> Either Error [(Symbol, Expr)]
parse_section [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    parse_section ((Line
lineno, Text
line0) : [(Line, Text)]
lines) =
        forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Line, Line) -> Error -> Error
ParseText.offset (Line
lineno, Line
0)) forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Text -> Either Error a
ParseText.parse Parser [(Symbol, Expr)]
p_section forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
Text.unlines (Text
line0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Line, Text)]
lines)

parse_instrument :: (Int, Text)
    -> Either ParseText.Error (Maybe Instruments.Allocation)
parse_instrument :: (Line, Text) -> Either Error (Maybe Allocation)
parse_instrument (Line
lineno, Text
line) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Error
fmt forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Text -> Either Text a
Util.Parse.parse ParsecT Void Text Identity (Maybe Allocation)
p Text
line
    where
    -- Instruments awkwardly use megaparsec, which the rest of the code here
    -- uses attoparsec.  The reason is attoparsec is for performance parsing
    -- tracklang, but I'd rather have better errors for parsing ky.  But I need
    -- to parse DeriveT.Vals, which I'd rather use the same parser as with
    -- tracklang.  Also, instruments are line-based rather than token based.
    p :: ParsecT Void Text Identity (Maybe Allocation)
p = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Allocation
Instruments.p_allocation
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
Instruments.spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    fmt :: Text -> Error
fmt Text
msg = ParseText.Error
        -- TODO I could extract the column from the megaparsec error
        { _position :: Maybe (Text, (Line, Line))
_position = forall a. a -> Maybe a
Just (Text
line, (Line
lineno, Line
1))
        , _message :: Text
_message = Text
msg
        }

-- | The alias section allows only @alias = inst@ definitions.
parse_alias :: (Expr.Symbol, Expr)
    -> Either Error (ScoreT.Instrument, ScoreT.Instrument)
parse_alias :: (Symbol, Expr) -> Either Text (Instrument, Instrument)
parse_alias (Symbol
lhs, Expr
rhs) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text
msg<>) forall a b. (a -> b) -> a -> b
$ case Expr
rhs of
    Expr (Call Symbol
rhs [] :| [])
        | Bool -> Bool
not (Text -> Bool
Id.valid_symbol (Symbol -> Text
Expr.unsym Symbol
lhs)) -> forall a b. a -> Either a b
Left Text
"lhs not a valid id"
        | Bool -> Bool
not (Text -> Bool
Id.valid_symbol (Symbol -> Text
Expr.unsym Symbol
rhs)) -> forall a b. a -> Either a b
Left Text
"rhs not a valid id"
        | Bool
otherwise -> forall a b. b -> Either a b
Right (Symbol -> Instrument
convert Symbol
lhs, Symbol -> Instrument
convert Symbol
rhs)
        where convert :: Symbol -> Instrument
convert (Expr.Symbol Text
a) = Text -> Instrument
ScoreT.Instrument Text
a
    Expr
_ -> forall a b. a -> Either a b
Left Text
"rhs not a symbol"
    where
    msg :: Text
msg = Text
"alias " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Symbol
lhs forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Expr
rhs
        forall a. Semigroup a => a -> a -> a
<> Text
": "

-- | Get UiConfig.ky with UiConfig.allocations merged in.  See
-- "Derive.Parse.Instruments".
get_ky :: Ui.M m => m Code
get_ky :: forall (m :: * -> *). M m => m Text
get_ky = do
    Text
ky <- Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Text
UiConfig.ky forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    Allocations
allocs <- Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Allocations
UiConfig.allocations forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    [Allocation]
allocs <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Ui.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Instrument -> Allocation -> Either Text Allocation
Instruments.from_ui) forall a b. (a -> b) -> a -> b
$
        forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Allocations -> Map Instrument Allocation
UiConfig.unallocations Allocations
allocs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Allocation] -> Text -> Text
merge_instruments [Allocation]
allocs Text
ky

-- | Update a ky instruments section with Allocations.
merge_instruments :: [Instruments.Allocation] -> Code -> Code
merge_instruments :: [Allocation] -> Text -> Text
merge_instruments [Allocation]
allocs = Text -> ([Text] -> [Text]) -> Text -> Text
replace_section Text
Instruments.instrument_section [Text] -> [Text]
merge
    where
    merge :: [Text] -> [Text]
merge [Text]
lines
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Instrument
added Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Instrument
removed = [Text]
lines -- Common case of no changes.
        | Bool
otherwise = [(Maybe Allocation, Text)] -> [Text]
Instruments.unparse_allocations forall a b. (a -> b) -> a -> b
$
            -- Added allocs have no comment.
            forall a b. (a -> b) -> [a] -> [b]
map ((, Text
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) [Allocation]
added_allocs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Instrument, Text) -> Maybe (Maybe Allocation, Text)
update [(Maybe Instrument, Text)]
inst_lines
        where
        added_allocs :: [Allocation]
added_allocs =
            forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Instrument
added) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> Instrument
Instruments.alloc_name) [Allocation]
allocs
        added :: Set Instrument
added = Set Instrument
new_insts forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Instrument
old_insts
        removed :: Set Instrument
removed = Set Instrument
old_insts forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Instrument
new_insts
        new_insts :: Set Instrument
new_insts = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Allocation -> Instrument
Instruments.alloc_name [Allocation]
allocs
        old_insts :: Set Instrument
old_insts = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> a
fst [(Maybe Instrument, Text)]
inst_lines)
        inst_lines :: [(Maybe Instrument, Text)]
inst_lines = forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn Text -> Maybe Instrument
inst_of [Text]
lines
    update :: (Maybe Instrument, Text) -> Maybe (Maybe Allocation, Text)
update (Maybe Instrument
Nothing, Text
line) = forall a. a -> Maybe a
Just (forall a. Maybe a
Nothing, Text
line)
    update (Just Instrument
inst, Text
line) = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Instrument
inst Map Instrument Allocation
inst_alloc of
        Maybe Allocation
Nothing -> forall a. Maybe a
Nothing
        Just Allocation
alloc -> forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just Allocation
alloc, Text
comment)
            where comment :: Text
comment = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Stack => Text -> Text -> (Text, Text)
Text.breakOn Text
"--" Text
line
    inst_alloc :: Map Instrument Allocation
inst_alloc = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn Allocation -> Instrument
Instruments.alloc_name [Allocation]
allocs)
    inst_of :: Text -> Maybe Instrument
inst_of = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> Instrument
Instruments.alloc_name)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either Text a
Util.Parse.parse Parser Allocation
Instruments.p_allocation

-- * parse ky file

-- | Most of the sections are not line-oriented, but the instrument section is.
-- Line numbers are used for to add as offsets to parsing errors.
type Section = (Title, [(Line, Text)])
type Title = Text
type Line = Int

-- | Split sections into a Map with section name keys, and numbered lines.
checked_sections :: Code -> Either Error (Code, Map Title [(Line, Text)])
checked_sections :: Text -> Either Text (Text, Map Text [(Line, Text)])
checked_sections = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {b} {b}. (b, [(Text, b)]) -> Either Text b
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {a}.
Ord k =>
[(k, [(a, Text)])]
-> (Text, (Map k [(a, Text)], [(k, [[(a, Text)]])]))
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Section]
parse_sections
    where
    check :: (b, [(Text, b)]) -> Either Text b
check (b
sections, []) = forall a b. b -> Either a b
Right b
sections
    check (b
_, [(Text, b)]
dups) =
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"duplicate sections: " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, b)]
dups)
    extract :: [(k, [(a, Text)])]
-> (Text, (Map k [(a, Text)], [(k, [[(a, Text)]])]))
extract ((k
_, [(a, Text)]
pre) : [(k, [(a, Text)])]
sections) =
        ([Text] -> Text
Text.unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, Text)]
pre), forall k v. Ord k => [(k, v)] -> (Map k v, [(k, [v])])
Maps.unique2 [(k, [(a, Text)])]
sections)
    extract [] = (Text
"", (forall a. Monoid a => a
mempty, []))

-- | Split ky code into Sections.  A Title of "" is used for the implicit
-- section before the first section title, used for imports.
parse_sections :: Code -> [Section]
parse_sections :: Text -> [Section]
parse_sections =
    forall {a} {b}. IsString a => (b, [(a, b)]) -> [(a, b)]
merge forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> ([a], [(b, [a])])
Lists.splitWith forall {a}. (a, Text) -> Maybe Text
parse_header forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Line
0..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
    where
    merge :: (b, [(a, b)]) -> [(a, b)]
merge (b
pre, [(a, b)]
sections) = (a
"", b
pre) forall a. a -> [a] -> [a]
: [(a, b)]
sections
    parse_header :: (a, Text) -> Maybe Text
parse_header (a
_, Text
line)
        | Bool -> Bool
not (Text
"--" Text -> Text -> Bool
`Text.isPrefixOf` Text
line), Just (Char
c, Text
_) <- Text -> Maybe (Char, Text)
Text.uncons Text
line
                , Bool -> Bool
not (Char -> Bool
Char.isSpace Char
c) =
            Text -> Text -> Maybe Text
Text.stripSuffix Text
":" Text
line
        | Bool
otherwise = forall a. Maybe a
Nothing

unparse_section :: (Title, [(line, Text)]) -> Code
unparse_section :: forall line. (Text, [(line, Text)]) -> Text
unparse_section (Text
section, [(line, Text)]
lines) =
    (if Text
section forall a. Eq a => a -> a -> Bool
== Text
"" then Text
"" else Text
section forall a. Semigroup a => a -> a -> a
<> Text
":\n")
        forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(line, Text)]
lines)

replace_section :: Title -> ([Text] -> [Text]) -> Code -> Code
replace_section :: Text -> ([Text] -> [Text]) -> Text -> Text
replace_section Text
title [Text] -> [Text]
modify Text
code =
    forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap forall line. (Text, [(line, Text)]) -> Text
unparse_section forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ if Bool
add_separator then forall a. (a -> a) -> [a] -> [a]
Lists.mapLast (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. [a] -> [a] -> [a]
++[(Line, Text)]
empty)) [Section]
pre else [Section]
pre
        , [(Text
title, forall a b. (a -> b) -> [a] -> [b]
map (Line
0,) [Text]
new) | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
new)]
        , forall a. Line -> [a] -> [a]
drop Line
1 [Section]
post
        ]
    where
    -- Extra hack for aesthetics: add an extra line if there is a non-""
    -- section above and this section is inserted.
    add_separator :: Bool
add_separator = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Section]
post Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Eq a => a -> a -> Bool
==Text
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [Section]
pre))
    empty :: [(Line, Text)]
empty = [(Line
0, Text
"")]
    new :: [Text]
new = [Text] -> [Text]
modify forall a b. (a -> b) -> a -> b
$ case [Section]
post of
        [] -> []
        (Text
_, [(Line, Text)]
lines) : [Section]
_ -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Line, Text)]
lines
    sections :: [Section]
sections = Text -> [Section]
parse_sections Text
code
    ([Section]
pre, [Section]
post) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((forall a. Eq a => a -> a -> Bool
==Text
title) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [Section]
sections

-- * parse inside sections

p_imports :: A.Parser [FilePath]
p_imports :: Parser [String]
p_imports =
    forall (f :: * -> *) a. Alternative f => f a -> f ()
A.skipMany Parser ()
Parse.empty_line forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text String
p_import forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f ()
A.skipMany Parser ()
Parse.empty_line
    where
    p_import :: Parser Text String
p_import = Text -> Parser Text
A.string Text
"import" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
Parse.spaces
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> String
untxt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
Parse.p_single_quote_string)
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
Parse.spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
'\n'

p_section :: A.Parser [(Expr.Symbol, Expr)]
p_section :: Parser [(Symbol, Expr)]
p_section = forall (f :: * -> *) a. Alternative f => f a -> f ()
A.skipMany Parser ()
Parse.empty_line forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (Symbol, Expr)
p_definition
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f ()
A.skipMany Parser ()
Parse.empty_line

p_definition :: A.Parser (Expr.Symbol, Expr)
p_definition :: Parser (Symbol, Expr)
p_definition = do
    Symbol
assignee <- Bool -> Parser Symbol
Parse.p_symbol Bool
True
    Parser ()
Parse.spaces
    (Char -> Bool) -> Parser ()
A.skip (forall a. Eq a => a -> a -> Bool
==Char
'=')
    Parser ()
Parse.spaces
    Expr
expr <- Parser Expr
p_expr_ky
    forall (f :: * -> *) a. Alternative f => f a -> f ()
A.skipMany Parser ()
Parse.empty_line
    forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol
assignee, Expr
expr)

-- * types

-- | These are parallel to the 'Expr.Expr' types, except they add
-- 'VarTerm'.  The duplication is unfortunate, but as long as this remains
-- a simple AST it seems better than the various heavyweight techniques for
-- parameterizing an AST.
newtype Expr = Expr (NonEmpty Call)
    deriving (Line -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> String
$cshow :: Expr -> String
showsPrec :: Line -> Expr -> ShowS
$cshowsPrec :: Line -> Expr -> ShowS
Show)
data Call = Call !Expr.Symbol ![Term]
    deriving (Line -> Call -> ShowS
[Call] -> ShowS
Call -> String
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Call] -> ShowS
$cshowList :: [Call] -> ShowS
show :: Call -> String
$cshow :: Call -> String
showsPrec :: Line -> Call -> ShowS
$cshowsPrec :: Line -> Call -> ShowS
Show)
data Term = VarTerm !Var | ValCall !Call | Literal !DeriveT.Val
    deriving (Line -> Term -> ShowS
[Term] -> ShowS
Term -> String
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Term] -> ShowS
$cshowList :: [Term] -> ShowS
show :: Term -> String
$cshow :: Term -> String
showsPrec :: Line -> Term -> ShowS
$cshowsPrec :: Line -> Term -> ShowS
Show)
-- | A variable to be substituted via the "Derive.Call.Macro" mechanism.
newtype Var = Var Text deriving (Line -> Var -> ShowS
[Var] -> ShowS
Var -> String
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Var] -> ShowS
$cshowList :: [Var] -> ShowS
show :: Var -> String
$cshow :: Var -> String
showsPrec :: Line -> Var -> ShowS
$cshowsPrec :: Line -> Var -> ShowS
Show)

instance ShowVal.ShowVal Expr where
    show_val :: Expr -> Text
show_val (Expr NonEmpty Call
calls) = Text -> [Text] -> Text
Text.intercalate Text
" | " forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map forall a. ShowVal a => a -> Text
ShowVal.show_val (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Call
calls)

instance ShowVal.ShowVal Call where
    show_val :: Call -> Text
show_val (Call Symbol
sym [Term]
args) = [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$
        forall a. ShowVal a => a -> Text
ShowVal.show_val Symbol
sym forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. ShowVal a => a -> Text
ShowVal.show_val [Term]
args

instance ShowVal.ShowVal Term where
    show_val :: Term -> Text
show_val (VarTerm Var
var) = forall a. ShowVal a => a -> Text
ShowVal.show_val Var
var
    show_val (ValCall Call
call) = Text
"(" forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Call
call forall a. Semigroup a => a -> a -> a
<> Text
")"
    show_val (Literal Val
val) = forall a. ShowVal a => a -> Text
ShowVal.show_val Val
val

instance ShowVal.ShowVal Var where
    show_val :: Var -> Text
show_val (Var Text
name) = Text
"$" forall a. Semigroup a => a -> a -> a
<> Text
name

-- * parsers

-- | As 'Expr' parallels 'Expr.Expr', these parsers parallel 'p_expr' and so
-- on.
p_expr_ky :: A.Parser Expr
p_expr_ky :: Parser Expr
p_expr_ky = do
    -- It definitely matches at least one, because p_null_call always matches.
    Call
c : [Call]
cs <- forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
A.sepBy1 Parser Call
p_toplevel_call_ky Parser ()
Parse.p_pipe
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ NonEmpty Call -> Expr
Expr (Call
c forall a. a -> [a] -> NonEmpty a
:| [Call]
cs)

p_toplevel_call_ky :: A.Parser Call
p_toplevel_call_ky :: Parser Call
p_toplevel_call_ky =
    Call -> Call
call_to_ky forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Call
Parse.p_unparsed_expr
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Call
p_equal_ky
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Call
p_call_ky
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Call -> Call
call_to_ky forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser (Call a)
Parse.p_null_call

call_to_ky :: DeriveT.Call -> Call
call_to_ky :: Call -> Call
call_to_ky (Expr.Call Symbol
sym [Term Val]
args) = Symbol -> [Term] -> Call
Call Symbol
sym (forall a b. (a -> b) -> [a] -> [b]
map Term Val -> Term
convert [Term Val]
args)
    where
    convert :: Term Val -> Term
convert (Expr.Literal Val
val) = Val -> Term
Literal Val
val
    convert (Expr.ValCall Call
call) = Call -> Term
ValCall (Call -> Call
call_to_ky Call
call)

p_equal_ky :: A.Parser Call
p_equal_ky :: Parser Call
p_equal_ky = do
    (Str
lhs, Maybe Str
sym, [Term]
rhs) <- forall a. Parser a -> Parser (Str, Maybe Str, [a])
Parse.p_equal_generic Parser Term
p_term_ky
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Symbol -> [Term] -> Call
Call Symbol
Symbols.equal forall a b. (a -> b) -> a -> b
$
        Str -> Term
literal Str
lhs forall a. a -> [a] -> [a]
: [Term]
rhs forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) (Str -> Term
literal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Str
sym)
    where literal :: Str -> Term
literal = Val -> Term
Literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> Val
DeriveT.VStr

p_sub_call_ky :: A.Parser Call
p_sub_call_ky :: Parser Call
p_sub_call_ky = forall x y a. Parser x -> Parser y -> Parser a -> Parser a
ParseText.between (Char -> Parser Char
A.char Char
'(') (Char -> Parser Char
A.char Char
')') Parser Call
p_call_ky

p_call_ky :: A.Parser Call
p_call_ky :: Parser Call
p_call_ky = Symbol -> [Term] -> Call
Call forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
Parse.lexeme (Bool -> Parser Symbol
Parse.p_symbol Bool
False) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Term
p_term_ky

p_term_ky :: A.Parser Term
p_term_ky :: Parser Term
p_term_ky =
    forall a. Parser a -> Parser a
Parse.lexeme forall a b. (a -> b) -> a -> b
$ Var -> Term
VarTerm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Var
p_var
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Val -> Term
Literal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Val
Parse.p_val
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Call -> Term
ValCall forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Call
p_sub_call_ky

p_var :: A.Parser Var
p_var :: Parser Var
p_var = Char -> Parser Char
A.char Char
'$' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Var
Var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
A.takeWhile1 Char -> Bool
is_var_char)

is_var_char :: Char -> Bool
is_var_char :: Char -> Bool
is_var_char Char
c = Char
'a' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
|| Char
'z' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-'