-- Copyright 2016 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 #-}
-- | Load ky files, which are separate files containing call definitions.
-- The syntax is defined by 'Ky.parse_ky'.
module Cmd.Ky (
    update
    , set
    , load
    , compile_definitions
#ifdef TESTING
    , module Cmd.Ky
#endif
) where
import qualified Control.Monad.Except as Except
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified System.FilePath as FilePath

import qualified Util.Doc as Doc
import qualified Util.Log as Log
import qualified Util.ParseText as ParseText

import qualified Cmd.Cmd as Cmd
import qualified Derive.Call.Macro as Macro
import qualified Derive.Call.Module as Module
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.Parse.Instruments as Instruments
import qualified Derive.Parse.Ky as Ky
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig

import qualified Instrument.Inst as Inst
import qualified Instrument.InstT as InstT
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global


-- | Check if ky files have changed, and if they have, update
-- 'Cmd.state_ky_cache' and clear the performances.
update :: Ui.State -> Cmd.State -> Text
    -> IO (Maybe (Ui.State, Cmd.State, [Log.Msg]))
update :: State -> State -> Text -> IO (Maybe (State, State, [Msg]))
update State
ui_state State
cmd_state Text
ky_text =
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm ((Qualified -> Maybe Backend)
-> Maybe KyCache
-> Allocations
-> [FilePath]
-> Text
-> IO (Maybe ((KyCache, Allocations), [Msg]))
check_cache Qualified -> Maybe Backend
lookup_backend Maybe KyCache
cache Allocations
allocs [FilePath]
paths Text
ky_text) forall a b. (a -> b) -> a -> b
$
    \((KyCache
ky_cache, Allocations
allocs), [Msg]
logs) -> do
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just
            ( Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Allocations
UiConfig.allocations forall f a. Lens f a -> a -> f -> f
#= Allocations
allocs forall a b. (a -> b) -> a -> b
$
                -- Should already be set when Responder calls me, but not
                -- when 'set' calls me.
                Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Text
UiConfig.ky forall f a. Lens f a -> a -> f -> f
#= Text
ky_text forall a b. (a -> b) -> a -> b
$ State
ui_state
            , State
cmd_state
                { state_ky_cache :: Maybe KyCache
Cmd.state_ky_cache = forall a. a -> Maybe a
Just KyCache
ky_cache
                , state_play :: PlayState
Cmd.state_play = (State -> PlayState
Cmd.state_play State
cmd_state)
                    -- TODO should I kill threads?
                    { state_performance :: Map BlockId Performance
Cmd.state_performance = forall a. Monoid a => a
mempty
                    , state_current_performance :: Map BlockId Performance
Cmd.state_current_performance = forall a. Monoid a => a
mempty
                    , state_performance_threads :: Map BlockId Thread
Cmd.state_performance_threads = forall a. Monoid a => a
mempty
                    }
                }
            , [Msg]
logs
            )
    where
    lookup_backend :: Qualified -> Maybe Backend
lookup_backend = State -> Qualified -> Maybe Backend
Cmd.get_lookup_backend State
cmd_state
    allocs :: 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. Lens f a -> f -> a
#$ State
ui_state
    cache :: Maybe KyCache
cache = State -> Maybe KyCache
Cmd.state_ky_cache State
cmd_state
    paths :: [FilePath]
paths = State -> [FilePath]
state_ky_paths State
cmd_state

set :: Text -> Cmd.CmdT IO Text
set :: Text -> CmdT IO Text
set Text
ky_text = do
    State
cmd_state <- forall (m :: * -> *). M m => m State
Cmd.get
    State
ui_state <- forall (m :: * -> *). M m => m State
Ui.get
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (State -> State -> Text -> IO (Maybe (State, State, [Msg]))
update State
ui_state State
cmd_state Text
ky_text) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (State, State, [Msg])
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
        -- Logs are just boring stuff about reloaded files.
        Just (State
ui_state, State
cmd_state, [Msg]
_logs) ->
            case State -> Maybe KyCache
Cmd.state_ky_cache State
cmd_state of
                Just (Cmd.KyCache (Left Text
err) Fingerprint
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
err
                Maybe KyCache
_ -> do
                    forall (m :: * -> *). M m => State -> m ()
Cmd.put State
cmd_state
                    forall (m :: * -> *). M m => State -> m ()
Ui.unsafe_put State
ui_state
                    forall (m :: * -> *) a. Monad m => a -> m a
return Text
""

-- | Reload the ky files if they're out of date, Nothing if no reload is
-- needed.
check_cache :: (InstT.Qualified -> Maybe Inst.Backend) -> Maybe Cmd.KyCache
    -> UiConfig.Allocations -> [FilePath] -> Text
    -> IO (Maybe ((Cmd.KyCache, UiConfig.Allocations), [Log.Msg]))
check_cache :: (Qualified -> Maybe Backend)
-> Maybe KyCache
-> Allocations
-> [FilePath]
-> Text
-> IO (Maybe ((KyCache, Allocations), [Msg]))
check_cache Qualified -> Maybe Backend
lookup_backend Maybe KyCache
prev_cache Allocations
old_allocs [FilePath]
paths Text
ky_text = forall {a}.
ExceptT
  (Maybe Text)
  IO
  ((Builtins, InstrumentAliases, Fingerprint, Allocations), [a])
-> IO (Maybe ((KyCache, Allocations), [a]))
run forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_permanent forall {a}. ExceptT (Maybe Text) IO a
abort
    Ky.Ky Definitions
defs [Loaded]
imported Maybe [Allocation]
mb_allocs <- forall {a}. Either Text a -> ExceptT (Maybe Text) IO a
try 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 Error -> Text
ParseText.show_error
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([FilePath] -> Text -> IO (Either Error (Ky Loaded))
Ky.load_ky [FilePath]
paths Text
ky_text)
    -- This uses the contents of all the files for the fingerprint, which
    -- means it has to read and parse them on each respond cycle.  If this
    -- turns out to be too expensive, I can go back to the modification time
    -- like I had before.
    let fingerprint :: Fingerprint
fingerprint = [Loaded] -> Fingerprint
Cmd.fingerprint [Loaded]
imported
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Fingerprint
old_fingerprint forall a. Eq a => a -> a -> Bool
== Fingerprint
fingerprint) forall {a}. ExceptT (Maybe Text) IO a
abort
    let (Builtins
builtins, [Msg]
logs) = [FilePath] -> Library -> (Builtins, [Msg])
compile_library ([Loaded] -> [FilePath]
loaded_fnames [Loaded]
imported) forall a b. (a -> b) -> a -> b
$
            Definitions -> Library
compile_definitions Definitions
defs
    Allocations
allocs <- case Maybe [Allocation]
mb_allocs of
        -- TODO this means deleting the whole section will have no effect,
        -- rather than removing all allocations.  This is a bit inconsistent,
        -- but I may have done it this way for historical reasons, since old ky
        -- files won't have instrument sections?
        Maybe [Allocation]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Allocations
old_allocs
        Just [Allocation]
allocs -> forall {a}. Either Text a -> ExceptT (Maybe Text) IO a
try forall a b. (a -> b) -> a -> b
$
            (Qualified -> Maybe Backend)
-> [Allocation] -> Allocations -> Either Text Allocations
Instruments.update_ui Qualified -> Maybe Backend
lookup_backend [Allocation]
allocs Allocations
old_allocs
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( (Builtins
builtins, forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Definitions -> [(Instrument, Instrument)]
Ky.def_aliases Definitions
defs), Fingerprint
fingerprint, Allocations
allocs)
        , [Msg]
logs
        )
    where
    run :: ExceptT
  (Maybe Text)
  IO
  ((Builtins, InstrumentAliases, Fingerprint, Allocations), [a])
-> IO (Maybe ((KyCache, Allocations), [a]))
run = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}.
Either
  (Maybe Text)
  ((Builtins, InstrumentAliases, Fingerprint, Allocations), [a])
-> Maybe ((KyCache, Allocations), [a])
apply forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT
    apply :: Either
  (Maybe Text)
  ((Builtins, InstrumentAliases, Fingerprint, Allocations), [a])
-> Maybe ((KyCache, Allocations), [a])
apply (Left Maybe Text
Nothing) = forall a. Maybe a
Nothing
    apply (Left (Just Text
err))
        | Text -> Bool
failed_previously Text
err = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just ((Either Text (Builtins, InstrumentAliases) -> Fingerprint -> KyCache
Cmd.KyCache (forall a b. a -> Either a b
Left Text
err) forall a. Monoid a => a
mempty, Allocations
old_allocs), [])
    apply (Right ((Builtins
builtins, InstrumentAliases
aliases, Fingerprint
fingerprint, Allocations
allocs), [a]
logs)) = forall a. a -> Maybe a
Just
        ((Either Text (Builtins, InstrumentAliases) -> Fingerprint -> KyCache
Cmd.KyCache (forall a b. b -> Either a b
Right (Builtins
builtins, InstrumentAliases
aliases)) Fingerprint
fingerprint, Allocations
allocs), [a]
logs)
    try :: Either Text a -> ExceptT (Maybe Text) IO a
try = 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 forall a. a -> Maybe a
Just
    abort :: ExceptT (Maybe Text) IO a
abort = forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a. Maybe a
Nothing
    old_fingerprint :: Fingerprint
old_fingerprint = case Maybe KyCache
prev_cache of
        Just (Cmd.KyCache Either Text (Builtins, InstrumentAliases)
_ Fingerprint
fprint) -> Fingerprint
fprint
        Maybe KyCache
_ -> forall a. Monoid a => a
mempty
    is_permanent :: Bool
is_permanent = case Maybe KyCache
prev_cache of
        Just (Cmd.PermanentKy {}) -> Bool
True
        Maybe KyCache
_ -> Bool
False
    -- If it failed last time then don't replace the error.  Otherwise, I'll
    -- continually clear the performance and get an endless loop.
    failed_previously :: Text -> Bool
failed_previously Text
err = case Maybe KyCache
prev_cache of
        Just (Cmd.KyCache (Left Text
old_err) Fingerprint
_) -> Text
err forall a. Eq a => a -> a -> Bool
== Text
old_err
        Maybe KyCache
_ -> Bool
False

-- | Like 'check_cache', but assuming no existing cmd or ui state.
load :: [FilePath] -> Text
    -> IO (Either Text (Derive.Builtins, Derive.InstrumentAliases))
load :: [FilePath]
-> Text -> IO (Either Text (Builtins, InstrumentAliases))
load [FilePath]
paths Text
ky_text =
    forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Error -> Text
ParseText.show_error Ky Loaded -> (Builtins, InstrumentAliases)
compile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([FilePath] -> Text -> IO (Either Error (Ky Loaded))
Ky.load_ky [FilePath]
paths Text
ky_text)
    where
    -- Instrument allocations are stored in the score state, and if there is
    -- anything in the ky text it should be the same as in the score state.
    -- If I ever move the the state entirely to ky then this will need to
    -- parse and return them, but meanwhile existing scores don't have allocs
    -- in the ky.
    compile :: Ky Loaded -> (Builtins, InstrumentAliases)
compile (Ky.Ky Definitions
defs [Loaded]
imported Maybe [Allocation]
_allocs) =
        (Builtins
builtins, forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Definitions -> [(Instrument, Instrument)]
Ky.def_aliases Definitions
defs))
        where
        -- Logs are boring, just loaded this or that.
        (Builtins
builtins, [Msg]
_logs) = [FilePath] -> Library -> (Builtins, [Msg])
compile_library ([Loaded] -> [FilePath]
loaded_fnames [Loaded]
imported) forall a b. (a -> b) -> a -> b
$
            Definitions -> Library
compile_definitions Definitions
defs

loaded_fnames :: [Ky.Loaded] -> [FilePath]
loaded_fnames :: [Loaded] -> [FilePath]
loaded_fnames [Loaded]
loads = [FilePath
fname | Ky.Loaded FilePath
fname Text
_ <- [Loaded]
loads]

state_ky_paths :: Cmd.State -> [FilePath]
state_ky_paths :: State -> [FilePath]
state_ky_paths State
cmd_state = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) (State -> Maybe FilePath
Cmd.state_save_dir State
cmd_state)
    (Config -> [FilePath]
Cmd.config_ky_paths (State -> Config
Cmd.state_config State
cmd_state))

compile_library :: [FilePath] -> Library.Library -> (Derive.Builtins, [Log.Msg])
compile_library :: [FilePath] -> Library -> (Builtins, [Msg])
compile_library [FilePath]
imports Library
lib = forall a. LogId a -> (a, [Msg])
Log.run_id forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). (HasCallStack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$
        Text
"reloaded ky: [" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
show_import [FilePath]
imports) forall a. Semigroup a => a -> a -> a
<> Text
"]"
    forall (m :: * -> *). LogMonad m => Library -> m Builtins
Library.compile_log Library
lib

show_import :: FilePath -> Text
show_import FilePath
"" = Text
"<score>"
show_import FilePath
fname = FilePath -> Text
txt (FilePath -> FilePath
FilePath.takeFileName FilePath
fname)

compile_definitions :: Ky.Definitions -> Library.Library
compile_definitions :: Definitions -> Library
compile_definitions (Ky.Definitions ([Definition]
gnote, [Definition]
tnote) ([Definition]
gcontrol, [Definition]
tcontrol)
        ([Definition]
gpitch, [Definition]
tpitch) [Definition]
val [(Instrument, Instrument)]
_aliases) =
    Derive.Scopes
        { scopes_generator :: Scope
  [Entry (Generator Note)]
  [Entry (Generator Control)]
  [Entry (Generator Pitch)]
scopes_generator = Derive.Scope
            { scope_note :: [Entry (Generator Note)]
scope_note = forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {t} {call}.
(t -> CallName -> t -> call) -> (t, (Symbol, t)) -> Entry call
compile forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Generator d
make_generator) [Definition]
gnote
            , scope_control :: [Entry (Generator Control)]
scope_control = forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {t} {call}.
(t -> CallName -> t -> call) -> (t, (Symbol, t)) -> Entry call
compile forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Generator d
make_generator) [Definition]
gcontrol
            , scope_pitch :: [Entry (Generator Pitch)]
scope_pitch = forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {t} {call}.
(t -> CallName -> t -> call) -> (t, (Symbol, t)) -> Entry call
compile forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Generator d
make_generator) [Definition]
gpitch
            }
        , scopes_transformer :: Scope
  [Entry (Transformer Note)]
  [Entry (Transformer Control)]
  [Entry (Transformer Pitch)]
scopes_transformer = Derive.Scope
            { scope_note :: [Entry (Transformer Note)]
scope_note = forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {t} {call}.
(t -> CallName -> t -> call) -> (t, (Symbol, t)) -> Entry call
compile forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Transformer d
make_transformer) [Definition]
tnote
            , scope_control :: [Entry (Transformer Control)]
scope_control = forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {t} {call}.
(t -> CallName -> t -> call) -> (t, (Symbol, t)) -> Entry call
compile forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Transformer d
make_transformer) [Definition]
tcontrol
            , scope_pitch :: [Entry (Transformer Pitch)]
scope_pitch = forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {t} {call}.
(t -> CallName -> t -> call) -> (t, (Symbol, t)) -> Entry call
compile forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Transformer d
make_transformer) [Definition]
tpitch
            }
        , scopes_track :: Scope
  [Entry (TrackCall Note)]
  [Entry (TrackCall Control)]
  [Entry (TrackCall Pitch)]
scopes_track = forall a. Monoid a => a
mempty
        , scopes_val :: [Entry ValCall]
scopes_val = forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {t} {call}.
(t -> CallName -> t -> call) -> (t, (Symbol, t)) -> Entry call
compile FilePath -> CallName -> Expr -> ValCall
make_val_call) [Definition]
val
        }
    where
    compile :: (t -> CallName -> t -> call) -> (t, (Symbol, t)) -> Entry call
compile t -> CallName -> t -> call
make (t
fname, (Symbol
sym, t
expr)) =
        forall call. Symbol -> call -> Entry call
Library.Single Symbol
sym (t -> CallName -> t -> call
make t
fname (Symbol -> CallName
sym_to_name Symbol
sym) t
expr)
    sym_to_name :: Symbol -> CallName
sym_to_name (Expr.Symbol Text
name) = Text -> CallName
Derive.CallName Text
name

make_generator :: Derive.CallableExpr d => FilePath -> Derive.CallName
    -> Ky.Expr -> Derive.Generator d
make_generator :: forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Generator d
make_generator FilePath
fname CallName
name Expr
var_expr
    | Just Expr
expr <- Expr -> Maybe Expr
no_free_vars Expr
var_expr = forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Generator d
simple_generator FilePath
fname CallName
name Expr
expr
    | Bool
otherwise = forall d.
CallableExpr d =>
Module -> CallName -> Tags -> Doc -> Expr -> Generator d
Macro.generator Module
Module.local CallName
name forall a. Monoid a => a
mempty
        (Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ Text
"Defined in " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
txt FilePath
fname forall a. Semigroup a => a -> a -> a
<> Text
".") Expr
var_expr

make_transformer :: Derive.CallableExpr d => FilePath -> Derive.CallName
    -> Ky.Expr -> Derive.Transformer d
make_transformer :: forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Transformer d
make_transformer FilePath
fname CallName
name Expr
var_expr
    | Just Expr
expr <- Expr -> Maybe Expr
no_free_vars Expr
var_expr = forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Transformer d
simple_transformer FilePath
fname CallName
name Expr
expr
    | Bool
otherwise = forall d.
CallableExpr d =>
Module -> CallName -> Tags -> Doc -> Expr -> Transformer d
Macro.transformer Module
Module.local CallName
name forall a. Monoid a => a
mempty
        (Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ Text
"Defined in " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
txt FilePath
fname forall a. Semigroup a => a -> a -> a
<> Text
".") Expr
var_expr

make_val_call :: FilePath -> Derive.CallName -> Ky.Expr -> Derive.ValCall
make_val_call :: FilePath -> CallName -> Expr -> ValCall
make_val_call FilePath
fname CallName
name Expr
var_expr
    | Just Expr
expr <- Expr -> Maybe Expr
no_free_vars Expr
var_expr = case Expr
expr of
        Call Val
call_expr :| [] -> FilePath -> CallName -> Call Val -> ValCall
simple_val_call FilePath
fname CallName
name Call Val
call_expr
        Expr
_ -> ValCall
broken
    | Bool
otherwise = case Expr
var_expr of
        Ky.Expr (Call
call_expr :| []) -> Module -> CallName -> Tags -> Doc -> Call -> ValCall
Macro.val_call Module
Module.local CallName
name forall a. Monoid a => a
mempty
            (Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ Text
"Defined in " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
txt FilePath
fname forall a. Semigroup a => a -> a -> a
<> Text
".") Call
call_expr
        Expr
_ -> ValCall
broken
    where
    broken :: ValCall
broken = CallName -> Text -> ValCall
broken_val_call CallName
name forall a b. (a -> b) -> a -> b
$
        Text
"Broken val call defined in " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
txt FilePath
fname
        forall a. Semigroup a => a -> a -> a
<> Text
": val calls don't support pipeline syntax: "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Expr
var_expr

simple_generator :: Derive.CallableExpr d => FilePath -> Derive.CallName
    -> DeriveT.Expr -> Derive.Generator d
simple_generator :: forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Generator d
simple_generator FilePath
fname CallName
name Expr
expr =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.local CallName
name forall a. Monoid a => a
mempty (FilePath -> CallName -> Expr -> Doc
make_doc FilePath
fname CallName
name Expr
expr) forall a b. (a -> b) -> a -> b
$
    case forall a. Expr a -> Maybe Symbol
assign_symbol Expr
expr of
        Maybe Symbol
Nothing -> forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall {d}.
(Callable (Transformer d), Callable (Generator d),
 Callable (TrackCall d), Taggable d) =>
PassedArgs d -> Deriver (Stream d)
generator
        Just Symbol
sym ->
            forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser [Val]
Sig.many_vals ArgName
"arg" Doc
"Args parsed by reapplied call.") forall a b. (a -> b) -> a -> b
$
                \[Val]
_vals PassedArgs d
args -> forall d.
Callable (Generator d) =>
PassedArgs d -> Symbol -> Deriver (Stream d)
Eval.reapply_generator PassedArgs d
args Symbol
sym
    where generator :: PassedArgs d -> Deriver (Stream d)
generator PassedArgs d
args = forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
Eval.eval_toplevel (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args) Expr
expr

simple_transformer :: Derive.CallableExpr d => FilePath -> Derive.CallName
    -> DeriveT.Expr -> Derive.Transformer d
simple_transformer :: forall d.
CallableExpr d =>
FilePath -> CallName -> Expr -> Transformer d
simple_transformer FilePath
fname CallName
name Expr
expr =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.local CallName
name forall a. Monoid a => a
mempty (FilePath -> CallName -> Expr -> Doc
make_doc FilePath
fname CallName
name Expr
expr) forall a b. (a -> b) -> a -> b
$
    case forall a. Expr a -> Maybe Symbol
assign_symbol Expr
expr of
        Maybe Symbol
Nothing -> forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall {d}.
(Callable (Transformer d), Taggable d) =>
PassedArgs d -> Deriver (Stream d) -> Deriver (Stream d)
transformer
        Just Symbol
sym ->
            forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (ArgName -> Doc -> Parser [Val]
Sig.many_vals ArgName
"arg" Doc
"Args parsed by reapplied call.") forall a b. (a -> b) -> a -> b
$
                \[Val]
_vals -> forall {val}.
Callable (Transformer val) =>
Symbol
-> PassedArgs val -> Deriver (Stream val) -> Deriver (Stream val)
reapply Symbol
sym
    where
    transformer :: PassedArgs d -> Deriver (Stream d) -> Deriver (Stream d)
transformer PassedArgs d
args Deriver (Stream d)
deriver =
        forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> [Call Val] -> Deriver (Stream d) -> Deriver (Stream d)
Eval.eval_transformers (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args)
            (forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
expr) Deriver (Stream d)
deriver
    reapply :: Symbol
-> PassedArgs val -> Deriver (Stream val) -> Deriver (Stream val)
reapply Symbol
sym PassedArgs val
args Deriver (Stream val)
deriver = do
        Transformer val
call <- forall d.
Callable (Transformer d) =>
Symbol -> Deriver (Transformer d)
Eval.get_transformer Symbol
sym
        forall d.
Context d
-> Transformer d
-> [Val]
-> Deriver (Stream d)
-> Deriver (Stream d)
Eval.apply_transformer (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs val
args) Transformer val
call
            (forall val. PassedArgs val -> [Val]
Derive.passed_vals PassedArgs val
args) Deriver (Stream val)
deriver

simple_val_call :: FilePath -> Derive.CallName -> DeriveT.Call
    -> Derive.ValCall
simple_val_call :: FilePath -> CallName -> Call Val -> ValCall
simple_val_call FilePath
fname CallName
name Call Val
call_expr =
    forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.local CallName
name forall a. Monoid a => a
mempty (FilePath -> CallName -> Expr -> Doc
make_doc FilePath
fname CallName
name Expr
expr) forall a b. (a -> b) -> a -> b
$
    case forall a. Expr a -> Maybe Symbol
assign_symbol Expr
expr of
        Maybe Symbol
Nothing -> forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ \PassedArgs Tagged
args ->
            forall a. Taggable a => Context a -> Term -> Deriver Val
Eval.eval (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs Tagged
args) (forall val. Call val -> Term val
Expr.ValCall Call Val
call_expr)
        Just Symbol
sym ->
            forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser [Val]
Sig.many_vals ArgName
"arg" Doc
"Args parsed by reapplied call.") forall a b. (a -> b) -> a -> b
$
                \[Val]
_vals -> Symbol -> PassedArgs Tagged -> Deriver Val
call_args Symbol
sym
    where
    expr :: Expr
expr = Call Val
call_expr forall a. a -> [a] -> NonEmpty a
:| []
    call_args :: Symbol -> PassedArgs Tagged -> Deriver Val
call_args Symbol
sym PassedArgs Tagged
args = do
        ValCall
call <- Symbol -> Deriver ValCall
Eval.get_val_call Symbol
sym
        ValCall -> PassedArgs Tagged -> Deriver Val
Derive.vcall_call ValCall
call forall a b. (a -> b) -> a -> b
$ PassedArgs Tagged
args
            { passed_call_name :: CallName
Derive.passed_call_name = ValCall -> CallName
Derive.vcall_name ValCall
call }

broken_val_call :: Derive.CallName -> Text -> Derive.ValCall
broken_val_call :: CallName -> Text -> ValCall
broken_val_call CallName
name Text
msg = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
Derive.make_val_call Module
Module.local CallName
name forall a. Monoid a => a
mempty
    (Text -> Doc
Doc.Doc Text
msg)
    (forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser [Val]
Sig.many_vals ArgName
"arg" Doc
"broken") forall a b. (a -> b) -> a -> b
$ \[Val]
_ PassedArgs Tagged
_ -> forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
msg)

-- | If the Ky.Expr has no 'Ky.VarTerm's, it doesn't need to be a macro.
no_free_vars :: Ky.Expr -> Maybe DeriveT.Expr
no_free_vars :: Expr -> Maybe Expr
no_free_vars (Ky.Expr NonEmpty Call
expr) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Call -> Maybe (Call Val)
convent_call NonEmpty Call
expr
    where
    convent_call :: Call -> Maybe (Call Val)
convent_call (Ky.Call Symbol
sym [Term]
terms) =
        forall val. Symbol -> [Term val] -> Call val
Expr.Call Symbol
sym forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Term -> Maybe Term
convert_term [Term]
terms
    convert_term :: Term -> Maybe Term
convert_term (Ky.VarTerm Var
_) = forall a. Maybe a
Nothing
    convert_term (Ky.ValCall Call
call) = forall val. Call val -> Term val
Expr.ValCall forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Call -> Maybe (Call Val)
convent_call Call
call
    convert_term (Ky.Literal Val
val) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall val. val -> Term val
Expr.Literal Val
val

make_doc :: FilePath -> Derive.CallName -> DeriveT.Expr -> Doc.Doc
make_doc :: FilePath -> CallName -> Expr -> Doc
make_doc FilePath
fname CallName
name Expr
expr = Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$
    forall a. Pretty a => a -> Text
pretty CallName
name forall a. Semigroup a => a -> a -> a
<> Text
" defined in " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
txt FilePath
fname 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
expr

-- | If there are arguments in the definition, then don't accept any in the
-- score.  I could do partial application, but it seems confusing, so
-- I won't add it unless I need it.
assign_symbol :: Expr.Expr a -> Maybe Expr.Symbol
assign_symbol :: forall a. Expr a -> Maybe Symbol
assign_symbol (Expr.Call Symbol
sym [] :| []) = forall a. a -> Maybe a
Just Symbol
sym
assign_symbol NonEmpty (Call a)
_ = forall a. Maybe a
Nothing