-- 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
    -- ** 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.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 qualified Data.Traversable as Traversable

import           System.FilePath ((</>))

import qualified Util.Exceptions as Exceptions
import qualified Util.ParseText as ParseText
import qualified Util.Seq as Seq

import qualified Derive.DeriveT as DeriveT
import qualified Derive.Expr as Expr
import qualified Derive.Parse as Parse
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           Global


-- | A parsed .ky file
data Ky a = Ky {
    forall a. Ky a -> Definitions
ky_definitions :: Definitions
    , forall a. Ky a -> [a]
ky_imports :: [a]
    } deriving (Int -> Ky a -> ShowS
[Ky a] -> ShowS
Ky a -> String
(Int -> Ky a -> ShowS)
-> (Ky a -> String) -> ([Ky a] -> ShowS) -> Show (Ky a)
forall a. Show a => Int -> Ky a -> ShowS
forall a. Show a => [Ky a] -> ShowS
forall a. Show a => Ky a -> String
forall a.
(Int -> 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 :: Int -> Ky a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Ky a -> ShowS
Show)

instance Semigroup (Ky a) where
    Ky Definitions
a1 [a]
b1 <> :: Ky a -> Ky a -> Ky a
<> Ky Definitions
a2 [a]
b2 = Definitions -> [a] -> Ky a
forall a. Definitions -> [a] -> Ky a
Ky (Definitions
a1Definitions -> Definitions -> Definitions
forall a. Semigroup a => a -> a -> a
<>Definitions
a2) ([a]
b1[a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<>[a]
b2)
instance Monoid (Ky a) where
    mempty :: Ky a
mempty = Definitions -> [a] -> Ky a
forall a. Definitions -> [a] -> Ky a
Ky Definitions
forall a. Monoid a => a
mempty [a]
forall a. Monoid a => a
mempty
    mappend :: Ky a -> Ky a -> Ky a
mappend = Ky a -> Ky a -> Ky a
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 !Text
    deriving (Loaded -> Loaded -> Bool
(Loaded -> Loaded -> Bool)
-> (Loaded -> Loaded -> Bool) -> Eq Loaded
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, Int -> Loaded -> ShowS
[Loaded] -> ShowS
Loaded -> String
(Int -> Loaded -> ShowS)
-> (Loaded -> String) -> ([Loaded] -> ShowS) -> Show Loaded
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Loaded] -> ShowS
$cshowList :: [Loaded] -> ShowS
show :: Loaded -> String
$cshow :: Loaded -> String
showsPrec :: Int -> Loaded -> ShowS
$cshowsPrec :: Int -> Loaded -> ShowS
Show)
-- | A requested import.  Path to .ky file, .ky files it imports.
data Import = Import !FilePath !String
    deriving (Import -> Import -> Bool
(Import -> Import -> Bool)
-> (Import -> Import -> Bool) -> Eq Import
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, Int -> Import -> ShowS
[Import] -> ShowS
Import -> String
(Int -> Import -> ShowS)
-> (Import -> String) -> ([Import] -> ShowS) -> Show Import
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Import] -> ShowS
$cshowList :: [Import] -> ShowS
show :: Import -> String
$cshow :: Import -> String
showsPrec :: Int -> Import -> ShowS
$cshowsPrec :: Int -> 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 (Int -> Definitions -> ShowS
[Definitions] -> ShowS
Definitions -> String
(Int -> Definitions -> ShowS)
-> (Definitions -> String)
-> ([Definitions] -> ShowS)
-> Show Definitions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Definitions] -> ShowS
$cshowList :: [Definitions] -> ShowS
show :: Definitions -> String
$cshow :: Definitions -> String
showsPrec :: Int -> Definitions -> ShowS
$cshowsPrec :: Int -> 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]
a1[Definition] -> [Definition] -> [Definition]
forall a. Semigroup a => a -> a -> a
<>[Definition]
a2, [Definition]
b1[Definition] -> [Definition] -> [Definition]
forall a. Semigroup a => a -> a -> a
<>[Definition]
b2) ([Definition]
c1[Definition] -> [Definition] -> [Definition]
forall a. Semigroup a => a -> a -> a
<>[Definition]
c2, [Definition]
d1[Definition] -> [Definition] -> [Definition]
forall a. Semigroup a => a -> a -> a
<>[Definition]
d2) ([Definition]
e1[Definition] -> [Definition] -> [Definition]
forall a. Semigroup a => a -> a -> a
<>[Definition]
e2, [Definition]
f1[Definition] -> [Definition] -> [Definition]
forall a. Semigroup a => a -> a -> a
<>[Definition]
f2) ([Definition]
g1[Definition] -> [Definition] -> [Definition]
forall a. Semigroup a => a -> a -> a
<>[Definition]
g2)
            ([(Instrument, Instrument)]
h1[(Instrument, Instrument)]
-> [(Instrument, Instrument)] -> [(Instrument, Instrument)]
forall 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 = Definitions -> Definitions -> Definitions
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] -> Text -> IO (Either ParseText.Error (Ky Loaded))
load_ky :: [String] -> Text -> IO (Either Error (Ky Loaded))
load_ky [String]
paths Text
content = ExceptT Error IO (Ky Loaded) -> IO (Either Error (Ky Loaded))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Error IO (Ky Loaded) -> IO (Either Error (Ky Loaded)))
-> ExceptT Error IO (Ky Loaded) -> IO (Either Error (Ky Loaded))
forall a b. (a -> b) -> a -> b
$ do
    Ky Import
ky <- Either Error (Ky Import) -> ExceptT Error IO (Ky Import)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight (Either Error (Ky Import) -> ExceptT Error IO (Ky Import))
-> Either Error (Ky Import) -> ExceptT Error IO (Ky Import)
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 Set String
forall a. Set a
Set.empty (Ky Import -> [Import]
forall a. Ky a -> [a]
ky_imports Ky Import
ky)
    Ky Loaded -> ExceptT Error IO (Ky Loaded)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ky Loaded -> ExceptT Error IO (Ky Loaded))
-> Ky Loaded -> ExceptT Error IO (Ky Loaded)
forall a b. (a -> b) -> a -> b
$ [Ky Loaded] -> Ky Loaded
forall a. Monoid a => [a] -> a
mconcat ([Ky Loaded] -> Ky Loaded) -> [Ky Loaded] -> Ky Loaded
forall a b. (a -> b) -> a -> b
$ Ky Import
ky { ky_imports :: [Loaded]
ky_imports = [String -> Text -> Loaded
Loaded String
"" Text
content] } Ky Loaded -> [Ky Loaded] -> [Ky Loaded]
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
_ [] = [Ky Loaded] -> ExceptT Error IO [Ky Loaded]
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 String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
loaded = [Ky Loaded] -> ExceptT Error IO [Ky Loaded]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Bool
otherwise = do
        let prefix :: Text
prefix = String -> Text
txt String
lib Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
        (String
fname, Text
content) <- Either Error (String, Text) -> ExceptT Error IO (String, Text)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight (Either Error (String, Text) -> ExceptT Error IO (String, Text))
-> (Either Text (String, Text) -> Either Error (String, Text))
-> Either Text (String, Text)
-> ExceptT Error IO (String, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Error)
-> Either Text (String, Text) -> Either Error (String, Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Error
ParseText.message (Text -> Error) -> (Text -> Text) -> Text -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
prefix<>))
            (Either Text (String, Text) -> ExceptT Error IO (String, Text))
-> ExceptT Error IO (Either Text (String, Text))
-> ExceptT Error IO (String, Text)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either Text (String, Text))
-> ExceptT Error IO (Either Text (String, Text))
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 <- Either Error (Ky Import) -> ExceptT Error IO (Ky Import)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight (Either Error (Ky Import) -> ExceptT Error IO (Ky Import))
-> (Either Error (Ky Import) -> Either Error (Ky Import))
-> Either Error (Ky Import)
-> ExceptT Error IO (Ky Import)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Error -> Error)
-> Either Error (Ky Import) -> Either Error (Ky Import)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Error -> Error
ParseText.prefix Text
prefix) (Either Error (Ky Import) -> ExceptT Error IO (Ky Import))
-> Either Error (Ky Import) -> ExceptT Error IO (Ky Import)
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 (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
lib Set String
loaded)
            ([Import]
imports [Import] -> [Import] -> [Import]
forall a. [a] -> [a] -> [a]
++ Ky Import -> [Import]
forall a. Ky a -> [a]
ky_imports Ky Import
ky)
        [Ky Loaded] -> ExceptT Error IO [Ky Loaded]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Ky Loaded] -> ExceptT Error IO [Ky Loaded])
-> [Ky Loaded] -> ExceptT Error IO [Ky Loaded]
forall a b. (a -> b) -> a -> b
$ Ky Import
ky { ky_imports :: [Loaded]
ky_imports = [String -> Text -> Loaded
Loaded String
fname Text
content] } Ky Loaded -> [Ky Loaded] -> [Ky Loaded]
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 Text (FilePath, Text))
find_ky :: [String] -> String -> String -> IO (Either Text (String, Text))
find_ky [String]
paths String
from String
fname =
    Text
-> IO (Either Text (String, Text))
-> IO (Either Text (String, Text))
forall a. Text -> IO (Either Text a) -> IO (Either Text a)
catch_io (String -> Text
txt String
fname) (IO (Either Text (String, Text))
 -> IO (Either Text (String, Text)))
-> IO (Either Text (String, Text))
-> IO (Either Text (String, Text))
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (String, Text) -> Either Text (String, Text)
forall err a. err -> Maybe a -> Either err a
justErr Text
msg (Maybe (String, Text) -> Either Text (String, Text))
-> IO (Maybe (String, Text)) -> IO (Either Text (String, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [IO (Maybe (String, Text))] -> IO (Maybe (String, Text))
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts ((String -> IO (Maybe (String, Text)))
-> [String] -> [IO (Maybe (String, Text))]
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: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
fname
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if String
from String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then Text
"" else Text
" from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
from)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (searched " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
txt [String]
paths) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    get :: String -> IO (Maybe (String, Text))
get String
fn = IO (String, Text) -> IO (Maybe (String, Text))
forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (IO (String, Text) -> IO (Maybe (String, Text)))
-> IO (String, Text) -> IO (Maybe (String, Text))
forall a b. (a -> b) -> a -> b
$ (,) String
fn (Text -> (String, Text)) -> IO Text -> IO (String, Text)
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 Text a) -> IO (Either Text a)
catch_io :: forall a. Text -> IO (Either Text a) -> IO (Either Text a)
catch_io Text
prefix IO (Either Text a)
io =
    (IOError -> Either Text a)
-> (Either Text a -> Either Text a)
-> Either IOError (Either Text a)
-> Either Text a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a)
-> (IOError -> Text) -> IOError -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) (Text -> Text) -> (IOError -> Text) -> IOError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Text
forall a. Show a => a -> Text
showt) Either Text a -> Either Text a
forall a. a -> a
id (Either IOError (Either Text a) -> Either Text a)
-> IO (Either IOError (Either Text a)) -> IO (Either Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either Text a) -> IO (Either IOError (Either Text a))
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 -> Text -> Either ParseText.Error (Ky Import)
parse_ky :: String -> Text -> Either Error (Ky Import)
parse_ky String
fname Text
text = do
    let (Text
imports, Map Text [(Int, Text)]
sections) = [Text] -> (Text, Map Text [(Int, Text)])
split_sections ([Text] -> (Text, Map Text [(Int, Text)]))
-> [Text] -> (Text, Map Text [(Int, Text)])
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
strip_comments ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines Text
text
    let extra :: [Text]
extra = Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$
            Map Text [(Int, Text)] -> Set Text
forall k a. Map k a -> Set k
Map.keysSet Map Text [(Int, Text)]
sections Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
valid_headers
    Bool -> Either Error () -> Either Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
extra) (Either Error () -> Either Error ())
-> Either Error () -> Either Error ()
forall a b. (a -> b) -> a -> b
$
        Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ Text -> Error
ParseText.message (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$
            Text
"unknown sections: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
extra
    [String]
imports <- Parser [String] -> Text -> Either Error [String]
forall a. Parser a -> Text -> Either Error a
ParseText.parse Parser [String]
p_imports Text
imports
    Map Text [(Symbol, Expr)]
parsed <- ([(Int, Text)] -> Either Error [(Symbol, Expr)])
-> Map Text [(Int, Text)]
-> Either Error (Map Text [(Symbol, Expr)])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Traversable.traverse [(Int, Text)] -> Either Error [(Symbol, Expr)]
parse_section Map Text [(Int, Text)]
sections
    let get :: Text -> [(Symbol, Expr)]
get Text
header = [(Symbol, Expr)]
-> Text -> Map Text [(Symbol, Expr)] -> [(Symbol, Expr)]
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
generator)
            , Text -> [(Symbol, Expr)]
get (Text
kind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
transformer)
            )
    [(Instrument, Instrument)]
aliases <- (Text -> Error)
-> Either Text [(Instrument, Instrument)]
-> Either Error [(Instrument, Instrument)]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Maybe (Text, (Int, Int)) -> Text -> Error
ParseText.Error Maybe (Text, (Int, Int))
forall a. Maybe a
Nothing) (Either Text [(Instrument, Instrument)]
 -> Either Error [(Instrument, Instrument)])
-> Either Text [(Instrument, Instrument)]
-> Either Error [(Instrument, Instrument)]
forall a b. (a -> b) -> a -> b
$ ((Symbol, Expr) -> Either Text (Instrument, Instrument))
-> [(Symbol, Expr)] -> Either Text [(Instrument, Instrument)]
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)
    let add_fname :: [a] -> [(String, a)]
add_fname = (a -> (String, a)) -> [a] -> [(String, a)]
forall a b. (a -> b) -> [a] -> [b]
map (String
fname,)
        add_fname2 :: ([a], [a]) -> ([(String, a)], [(String, a)])
add_fname2 = ([a] -> [(String, a)])
-> ([a] -> [(String, a)])
-> ([a], [a])
-> ([(String, a)], [(String, a)])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [a] -> [(String, a)]
forall {a}. [a] -> [(String, a)]
add_fname [a] -> [(String, a)]
forall {a}. [a] -> [(String, a)]
add_fname
    Ky Import -> Either Error (Ky Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ky Import -> Either Error (Ky Import))
-> Ky Import -> Either Error (Ky Import)
forall a b. (a -> b) -> a -> b
$ Ky
        { ky_definitions :: Definitions
ky_definitions = Definitions
            { def_note :: ([Definition], [Definition])
def_note = ([(Symbol, Expr)], [(Symbol, Expr)])
-> ([Definition], [Definition])
forall {a} {a}. ([a], [a]) -> ([(String, a)], [(String, a)])
add_fname2 (([(Symbol, Expr)], [(Symbol, Expr)])
 -> ([Definition], [Definition]))
-> ([(Symbol, Expr)], [(Symbol, Expr)])
-> ([Definition], [Definition])
forall a b. (a -> b) -> a -> b
$ Text -> ([(Symbol, Expr)], [(Symbol, Expr)])
get2 Text
note
            , def_control :: ([Definition], [Definition])
def_control = ([(Symbol, Expr)], [(Symbol, Expr)])
-> ([Definition], [Definition])
forall {a} {a}. ([a], [a]) -> ([(String, a)], [(String, a)])
add_fname2 (([(Symbol, Expr)], [(Symbol, Expr)])
 -> ([Definition], [Definition]))
-> ([(Symbol, Expr)], [(Symbol, Expr)])
-> ([Definition], [Definition])
forall a b. (a -> b) -> a -> b
$ Text -> ([(Symbol, Expr)], [(Symbol, Expr)])
get2 Text
control
            , def_pitch :: ([Definition], [Definition])
def_pitch = ([(Symbol, Expr)], [(Symbol, Expr)])
-> ([Definition], [Definition])
forall {a} {a}. ([a], [a]) -> ([(String, a)], [(String, a)])
add_fname2 (([(Symbol, Expr)], [(Symbol, Expr)])
 -> ([Definition], [Definition]))
-> ([(Symbol, Expr)], [(Symbol, Expr)])
-> ([Definition], [Definition])
forall a b. (a -> b) -> a -> b
$ Text -> ([(Symbol, Expr)], [(Symbol, Expr)])
get2 Text
pitch
            , def_val :: [Definition]
def_val = [(Symbol, Expr)] -> [Definition]
forall {a}. [a] -> [(String, a)]
add_fname ([(Symbol, Expr)] -> [Definition])
-> [(Symbol, Expr)] -> [Definition]
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 = (String -> Import) -> [String] -> [Import]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Import
Import String
fname) [String]
imports
        }
    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 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
alias Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
        [ Text
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> 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 :: [(Int, Text)] -> Either Error [(Symbol, Expr)]
parse_section [] = [(Symbol, Expr)] -> Either Error [(Symbol, Expr)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    parse_section ((Int
lineno, Text
line0) : [(Int, Text)]
lines) =
        (Error -> Error)
-> Either Error [(Symbol, Expr)] -> Either Error [(Symbol, Expr)]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Int, Int) -> Error -> Error
ParseText.offset (Int
lineno, Int
0)) (Either Error [(Symbol, Expr)] -> Either Error [(Symbol, Expr)])
-> Either Error [(Symbol, Expr)] -> Either Error [(Symbol, Expr)]
forall a b. (a -> b) -> a -> b
$ Parser [(Symbol, Expr)] -> Text -> Either Error [(Symbol, Expr)]
forall a. Parser a -> Text -> Either Error a
ParseText.parse Parser [(Symbol, Expr)]
p_section (Text -> Either Error [(Symbol, Expr)])
-> Text -> Either Error [(Symbol, Expr)]
forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
Text.unlines (Text
line0 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Int, Text) -> Text) -> [(Int, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Text) -> Text
forall a b. (a, b) -> b
snd [(Int, Text)]
lines)
    strip_comments :: [Text] -> [Text]
strip_comments = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"--" `Text.isPrefixOf`) (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.stripStart)

-- | The alias section allows only @alias = inst@ definitions.
parse_alias :: (Expr.Symbol, Expr)
    -> Either Text (ScoreT.Instrument, ScoreT.Instrument)
parse_alias :: (Symbol, Expr) -> Either Text (Instrument, Instrument)
parse_alias (Symbol
lhs, Expr
rhs) = (Text -> Text)
-> Either Text (Instrument, Instrument)
-> Either Text (Instrument, Instrument)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text
msg<>) (Either Text (Instrument, Instrument)
 -> Either Text (Instrument, Instrument))
-> Either Text (Instrument, Instrument)
-> Either Text (Instrument, Instrument)
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)) -> Text -> Either Text (Instrument, Instrument)
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)) -> Text -> Either Text (Instrument, Instrument)
forall a b. a -> Either a b
Left Text
"rhs not a valid id"
        | Bool
otherwise -> (Instrument, Instrument) -> Either Text (Instrument, Instrument)
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
_ -> Text -> Either Text (Instrument, Instrument)
forall a b. a -> Either a b
Left Text
"rhs not a symbol"
    where
    msg :: Text
msg = Text
"alias " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Symbol -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Symbol
lhs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Expr
rhs
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "

split_sections :: [Text] -> (Text, Map Text [(Int, Text)])
split_sections :: [Text] -> (Text, Map Text [(Int, Text)])
split_sections =
    ([[(Int, Text)]] -> Map Text [(Int, Text)])
-> (Text, [[(Int, Text)]]) -> (Text, Map Text [(Int, Text)])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (([(Int, Text)] -> [(Int, Text)] -> [(Int, Text)])
-> [(Text, [(Int, Text)])] -> Map Text [(Int, Text)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([(Int, Text)] -> [(Int, Text)] -> [(Int, Text)])
-> [(Int, Text)] -> [(Int, Text)] -> [(Int, Text)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(Int, Text)] -> [(Int, Text)] -> [(Int, Text)]
forall a. [a] -> [a] -> [a]
(++)) ([(Text, [(Int, Text)])] -> Map Text [(Int, Text)])
-> ([[(Int, Text)]] -> [(Text, [(Int, Text)])])
-> [[(Int, Text)]]
-> Map Text [(Int, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Int, Text)] -> [(Text, [(Int, Text)])])
-> [[(Int, Text)]] -> [(Text, [(Int, Text)])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(Int, Text)] -> [(Text, [(Int, Text)])]
forall {a}. [(a, Text)] -> [(Text, [(a, Text)])]
split_header)
        ((Text, [[(Int, Text)]]) -> (Text, Map Text [(Int, Text)]))
-> ([Text] -> (Text, [[(Int, Text)]]))
-> [Text]
-> (Text, Map Text [(Int, Text)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Int, Text)]] -> (Text, [[(Int, Text)]])
forall {a}. [[(a, Text)]] -> (Text, [[(a, Text)]])
split_imports ([[(Int, Text)]] -> (Text, [[(Int, Text)]]))
-> ([Text] -> [[(Int, Text)]]) -> [Text] -> (Text, [[(Int, Text)]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Text) -> Bool) -> [(Int, Text)] -> [[(Int, Text)]]
forall a. (a -> Bool) -> [a] -> [[a]]
Seq.split_before (Int, Text) -> Bool
forall {a}. (a, Text) -> Bool
is_header ([(Int, Text)] -> [[(Int, Text)]])
-> ([Text] -> [(Int, Text)]) -> [Text] -> [[(Int, Text)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
    where
    is_header :: (a, Text) -> Bool
is_header = (Text
":" `Text.isSuffixOf`) (Text -> Bool) -> ((a, Text) -> Text) -> (a, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Text) -> Text
forall a b. (a, b) -> b
snd
    split_imports :: [[(a, Text)]] -> (Text, [[(a, Text)]])
split_imports [] = (Text
"", [])
    split_imports ([] : [[(a, Text)]]
sections) = (Text
"", [[(a, Text)]]
sections)
    split_imports ([(a, Text)]
imports : [[(a, Text)]]
sections) =
        ([Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((a, Text) -> Text) -> [(a, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (a, Text) -> Text
forall a b. (a, b) -> b
snd [(a, Text)]
imports, [[(a, Text)]]
sections)
    strip_colon :: (a, Text) -> Text
strip_colon (a
_, Text
header) = Int -> Text -> Text
Text.take (Text -> Int
Text.length Text
header Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
header
    split_header :: [(a, Text)] -> [(Text, [(a, Text)])]
split_header [] = []
    split_header ((a, Text)
header : [(a, Text)]
section) = [((a, Text) -> Text
forall {a}. (a, Text) -> Text
strip_colon (a, Text)
header, [(a, Text)]
section)]

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

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

p_definition :: A.Parser (Expr.Symbol, Expr)
p_definition :: Parser Text (Symbol, Expr)
p_definition = do
    Symbol
assignee <- Bool -> Parser Symbol
Parse.p_symbol Bool
True
    Parser Text ()
Parse.spaces
    (Char -> Bool) -> Parser Text ()
A.skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=')
    Parser Text ()
Parse.spaces
    Expr
expr <- Parser Expr
p_expr_ky
    Parser Text () -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
A.skipMany Parser Text ()
Parse.empty_line
    (Symbol, Expr) -> Parser Text (Symbol, Expr)
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 (Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
(Int -> Expr -> ShowS)
-> (Expr -> String) -> ([Expr] -> ShowS) -> Show Expr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> String
$cshow :: Expr -> String
showsPrec :: Int -> Expr -> ShowS
$cshowsPrec :: Int -> Expr -> ShowS
Show)
data Call = Call !Expr.Symbol ![Term]
    deriving (Int -> Call -> ShowS
[Call] -> ShowS
Call -> String
(Int -> Call -> ShowS)
-> (Call -> String) -> ([Call] -> ShowS) -> Show Call
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Call] -> ShowS
$cshowList :: [Call] -> ShowS
show :: Call -> String
$cshow :: Call -> String
showsPrec :: Int -> Call -> ShowS
$cshowsPrec :: Int -> Call -> ShowS
Show)
data Term = VarTerm !Var | ValCall !Call | Literal !DeriveT.Val
    deriving (Int -> Term -> ShowS
[Term] -> ShowS
Term -> String
(Int -> Term -> ShowS)
-> (Term -> String) -> ([Term] -> ShowS) -> Show Term
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Term] -> ShowS
$cshowList :: [Term] -> ShowS
show :: Term -> String
$cshow :: Term -> String
showsPrec :: Int -> Term -> ShowS
$cshowsPrec :: Int -> Term -> ShowS
Show)
-- | A variable to be substituted via the "Derive.Call.Macro" mechanism.
newtype Var = Var Text deriving (Int -> Var -> ShowS
[Var] -> ShowS
Var -> String
(Int -> Var -> ShowS)
-> (Var -> String) -> ([Var] -> ShowS) -> Show Var
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Var] -> ShowS
$cshowList :: [Var] -> ShowS
show :: Var -> String
$cshow :: Var -> String
showsPrec :: Int -> Var -> ShowS
$cshowsPrec :: Int -> Var -> ShowS
Show)

instance ShowVal.ShowVal Expr where
    show_val :: Expr -> Text
show_val (Expr NonEmpty Call
calls) = Text -> [Text] -> Text
Text.intercalate Text
" | " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        (Call -> Text) -> [Call] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Call -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val (NonEmpty Call -> [Call]
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 ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        Symbol -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Symbol
sym Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Term -> Text) -> [Term] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Text
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) = Var -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Var
var
    show_val (ValCall Call
call) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Call -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Call
call Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    show_val (Literal Val
val) = Val -> Text
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
"$" Text -> Text -> 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 <- Parser Text Call -> Parser Text () -> Parser Text [Call]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
A.sepBy1 Parser Text Call
p_toplevel_call_ky Parser Text ()
Parse.p_pipe
    Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ NonEmpty Call -> Expr
Expr (Call
c Call -> [Call] -> NonEmpty Call
forall a. a -> [a] -> NonEmpty a
:| [Call]
cs)

p_toplevel_call_ky :: A.Parser Call
p_toplevel_call_ky :: Parser Text Call
p_toplevel_call_ky =
    Call -> Call
call_to_ky (Call -> Call) -> Parser Text Call -> Parser Text Call
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Call
Parse.p_unparsed_expr
    Parser Text Call -> Parser Text Call -> Parser Text Call
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Call
p_equal_ky
    Parser Text Call -> Parser Text Call -> Parser Text Call
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Call
p_call_ky
    Parser Text Call -> Parser Text Call -> Parser Text Call
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Call -> Call
call_to_ky (Call -> Call) -> Parser Text Call -> Parser Text Call
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Call
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 ((Term Val -> Term) -> [Term Val] -> [Term]
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 Text Call
p_equal_ky = do
    (Str
lhs, Maybe Str
sym, [Term]
rhs) <- Parser Term -> Parser (Str, Maybe Str, [Term])
forall a. Parser a -> Parser (Str, Maybe Str, [a])
Parse.p_equal_generic Parser Term
p_term_ky
    Call -> Parser Text Call
forall (m :: * -> *) a. Monad m => a -> m a
return (Call -> Parser Text Call) -> Call -> Parser Text Call
forall a b. (a -> b) -> a -> b
$ Symbol -> [Term] -> Call
Call Symbol
Symbols.equal ([Term] -> Call) -> [Term] -> Call
forall a b. (a -> b) -> a -> b
$
        Str -> Term
literal Str
lhs Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
rhs [Term] -> [Term] -> [Term]
forall a. [a] -> [a] -> [a]
++ [Term] -> (Term -> [Term]) -> Maybe Term -> [Term]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[]) (Str -> Term
literal (Str -> Term) -> Maybe Str -> Maybe Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Str
sym)
    where literal :: Str -> Term
literal = Val -> Term
Literal (Val -> Term) -> (Str -> Val) -> Str -> Term
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 Text Call
p_sub_call_ky = Parser Text Char
-> Parser Text Char -> Parser Text Call -> Parser Text Call
forall x y a. Parser x -> Parser y -> Parser a -> Parser a
ParseText.between (Char -> Parser Text Char
A.char Char
'(') (Char -> Parser Text Char
A.char Char
')') Parser Text Call
p_call_ky

p_call_ky :: A.Parser Call
p_call_ky :: Parser Text Call
p_call_ky = Symbol -> [Term] -> Call
Call (Symbol -> [Term] -> Call)
-> Parser Symbol -> Parser Text ([Term] -> Call)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Symbol -> Parser Symbol
forall a. Parser a -> Parser a
Parse.lexeme (Bool -> Parser Symbol
Parse.p_symbol Bool
False) Parser Text ([Term] -> Call)
-> Parser Text [Term] -> Parser Text Call
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Term -> Parser Text [Term]
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 =
    Parser Term -> Parser Term
forall a. Parser a -> Parser a
Parse.lexeme (Parser Term -> Parser Term) -> Parser Term -> Parser Term
forall a b. (a -> b) -> a -> b
$ Var -> Term
VarTerm (Var -> Term) -> Parser Text Var -> Parser Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Var
p_var
    Parser Term -> Parser Term -> Parser Term
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Val -> Term
Literal (Val -> Term) -> Parser Text Val -> Parser Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Val
Parse.p_val
    Parser Term -> Parser Term -> Parser Term
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Call -> Term
ValCall (Call -> Term) -> Parser Text Call -> Parser Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Call
p_sub_call_ky

p_var :: A.Parser Var
p_var :: Parser Text Var
p_var = Char -> Parser Text Char
A.char Char
'$' Parser Text Char -> Parser Text Var -> Parser Text Var
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Var
Var (Text -> Var) -> Parser Text -> Parser Text 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' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
|| Char
'z' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'