-- 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 #-}
-- | Create macros, which are calls that can substitute arguments into
-- an expression.  E.g. @apply-start-offset | start-s = (cf-rnd-a $distance)@.
module Derive.Call.Macro (
    generator, transformer, val_call
#ifdef TESTING
    , module Derive.Call.Macro
#endif
) where
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.State as Monad.State

import qualified Data.List.NonEmpty as NonEmpty

import qualified Util.Doc as Doc
import qualified Util.NEs as NEs
import qualified Util.Texts as Texts

import qualified Derive.Call.Module as Module
import qualified Derive.Call.Tags as Tags
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.Parse.Ky as Ky
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.ValType as ValType

import           Global


generator :: Derive.CallableExpr d => Module.Module -> Derive.CallName
    -> Tags.Tags -> Doc.Doc -> Ky.Expr -> Derive.Generator d
generator :: forall d.
CallableExpr d =>
Module -> CallName -> Tags -> Doc -> Expr -> Generator d
generator Module
module_ CallName
name Tags
tags Doc
doc Expr
expr =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
name Tags
tags (Doc -> Expr -> Doc
make_doc Doc
doc Expr
expr) forall a b. (a -> b) -> a -> b
$
        forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ([(Var, Symbol, Int)] -> Parser [Arg]
make_signature (Expr -> [(Var, Symbol, Int)]
extract_vars Expr
expr)) (forall d.
CallableExpr d =>
Expr -> [Arg] -> PassedArgs d -> Deriver (Stream d)
generator_macro Expr
expr)

transformer :: Derive.CallableExpr d => Module.Module -> Derive.CallName
    -> Tags.Tags -> Doc.Doc -> Ky.Expr -> Derive.Transformer d
transformer :: forall d.
CallableExpr d =>
Module -> CallName -> Tags -> Doc -> Expr -> Transformer d
transformer Module
module_ CallName
name Tags
tags Doc
doc Expr
expr =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
name Tags
tags (Doc -> Expr -> Doc
make_doc Doc
doc Expr
expr) forall a b. (a -> b) -> a -> b
$
        forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt ([(Var, Symbol, Int)] -> Parser [Arg]
make_signature (Expr -> [(Var, Symbol, Int)]
extract_vars Expr
expr)) (forall d.
CallableExpr d =>
Expr
-> [Arg]
-> PassedArgs d
-> Deriver (Stream d)
-> Deriver (Stream d)
transformer_macro Expr
expr)

val_call :: Module.Module -> Derive.CallName -> Tags.Tags -> Doc.Doc
    -> Ky.Call -> Derive.ValCall
val_call :: Module -> CallName -> Tags -> Doc -> Call -> ValCall
val_call Module
module_ CallName
name Tags
tags Doc
doc Call
call_expr =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
Derive.make_val_call Module
module_ CallName
name Tags
tags (Doc -> Expr -> Doc
make_doc Doc
doc Expr
expr) forall a b. (a -> b) -> a -> b
$
        forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ([(Var, Symbol, Int)] -> Parser [Arg]
make_signature (Expr -> [(Var, Symbol, Int)]
extract_vars Expr
expr)) (Call -> [Arg] -> PassedArgs Tagged -> Deriver Val
val_macro Call
call_expr)
    where expr :: Expr
expr = NonEmpty Call -> Expr
Ky.Expr (Call
call_expr forall a. a -> [a] -> NonEmpty a
:| [])

extract_vars :: Ky.Expr -> [(Ky.Var, Expr.Symbol, Int)]
extract_vars :: Expr -> [(Var, Symbol, Int)]
extract_vars (Ky.Expr NonEmpty Call
calls) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {c}. (Num c, Enum c) => Call -> [(Var, Symbol, c)]
extract_call (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Call
calls)
    where
    extract_call :: Call -> [(Var, Symbol, c)]
extract_call (Ky.Call Symbol
sym [Term]
args) =
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Symbol -> (c, Term) -> [(Var, Symbol, c)]
extract_arg Symbol
sym) (forall a b. [a] -> [b] -> [(a, b)]
zip [c
0..] [Term]
args)
    extract_arg :: Symbol -> (c, Term) -> [(Var, Symbol, c)]
extract_arg Symbol
sym (c
argnum, Term
arg) = case Term
arg of
        Ky.VarTerm Var
var -> [(Var
var, Symbol
sym, c
argnum)]
        Ky.Literal Val
_ -> []
        Ky.ValCall Call
call -> Call -> [(Var, Symbol, c)]
extract_call Call
call

generator_macro :: Derive.CallableExpr d => Ky.Expr -> [Sig.Arg]
    -> Derive.PassedArgs d -> Derive.Deriver (Stream.Stream d)
generator_macro :: forall d.
CallableExpr d =>
Expr -> [Arg] -> PassedArgs d -> Deriver (Stream d)
generator_macro Expr
expr [Arg]
vals PassedArgs d
args = do
    [Val]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Arg -> Deriver Val
require_val [Arg]
vals
    Expr
expr <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [Val] -> Expr -> Either Text Expr
substitute_vars [Val]
vals Expr
expr
    let ([Call]
trans, Call
gen) = Expr -> ([Call], Call)
split_expr Expr
expr
    let ctx :: Context d
ctx = forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args
    ([Symbol]
trans_calls, [[Val]]
trans_args) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a.
Taggable a =>
Context a -> Call -> Deriver (Symbol, [Val])
eval_args Context d
ctx) [Call]
trans
    [Transformer d]
trans_calls <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall d.
Callable (Transformer d) =>
Symbol -> Deriver (Transformer d)
Eval.get_transformer [Symbol]
trans_calls
    (Symbol
gen_call, [Val]
gen_args) <- forall a.
Taggable a =>
Context a -> Call -> Deriver (Symbol, [Val])
eval_args Context d
ctx Call
gen
    Generator d
gen_call <- forall d. Callable (Generator d) => Symbol -> Deriver (Generator d)
Eval.get_generator Symbol
gen_call
    forall d.
Context d
-> [(Transformer d, [Val])]
-> Deriver (Stream d)
-> Deriver (Stream d)
Eval.apply_transformers Context d
ctx (forall a b. [a] -> [b] -> [(a, b)]
zip [Transformer d]
trans_calls [[Val]]
trans_args) forall a b. (a -> b) -> a -> b
$
        forall d. Context d -> Generator d -> [Val] -> Deriver (Stream d)
Eval.apply_generator Context d
ctx Generator d
gen_call [Val]
gen_args

transformer_macro :: Derive.CallableExpr d => Ky.Expr
    -> [Sig.Arg] -> Derive.PassedArgs d
    -> Derive.Deriver (Stream.Stream d) -> Derive.Deriver (Stream.Stream d)
transformer_macro :: forall d.
CallableExpr d =>
Expr
-> [Arg]
-> PassedArgs d
-> Deriver (Stream d)
-> Deriver (Stream d)
transformer_macro Expr
expr [Arg]
vals PassedArgs d
args Deriver (Stream d)
deriver = do
    [Val]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Arg -> Deriver Val
require_val [Arg]
vals
    Expr
calls <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [Val] -> Expr -> Either Text Expr
substitute_vars [Val]
vals Expr
expr
    let ctx :: Context d
ctx = forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args
    ([Symbol]
trans_calls, [[Val]]
trans_args) <-
        forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a.
Taggable a =>
Context a -> Call -> Deriver (Symbol, [Val])
eval_args Context d
ctx) (forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
calls)
    [Transformer d]
trans_calls <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall d.
Callable (Transformer d) =>
Symbol -> Deriver (Transformer d)
Eval.get_transformer [Symbol]
trans_calls
    forall d.
Context d
-> [(Transformer d, [Val])]
-> Deriver (Stream d)
-> Deriver (Stream d)
Eval.apply_transformers Context d
ctx (forall a b. [a] -> [b] -> [(a, b)]
zip [Transformer d]
trans_calls [[Val]]
trans_args) Deriver (Stream d)
deriver

val_macro :: Ky.Call -> [Sig.Arg] -> Derive.PassedArgs Derive.Tagged
    -> Derive.Deriver DeriveT.Val
val_macro :: Call -> [Arg] -> PassedArgs Tagged -> Deriver Val
val_macro Call
call_expr [Arg]
vals PassedArgs Tagged
args = do
    [Val]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Arg -> Deriver Val
require_val [Arg]
vals
    Call
call_expr :| [Call]
_ <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
        [Val] -> Expr -> Either Text Expr
substitute_vars [Val]
vals (NonEmpty Call -> Expr
Ky.Expr (Call
call_expr forall a. a -> [a] -> NonEmpty a
:| []))
    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
call_expr)

split_expr :: DeriveT.Expr -> ([DeriveT.Call], DeriveT.Call)
split_expr :: Expr -> ([Call], Call)
split_expr = forall a. NonEmpty a -> ([a], a)
NEs.unsnoc

eval_args :: Derive.Taggable a => Derive.Context a -> DeriveT.Call
    -> Derive.Deriver (Expr.Symbol, [DeriveT.Val])
eval_args :: forall a.
Taggable a =>
Context a -> Call -> Deriver (Symbol, [Val])
eval_args Context a
ctx (Expr.Call Symbol
sym [Term]
args) = (,) Symbol
sym forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. Taggable a => Context a -> Term -> Deriver Val
Eval.eval Context a
ctx) [Term]
args

substitute_vars :: [DeriveT.Val] -> Ky.Expr -> Either Text DeriveT.Expr
substitute_vars :: [Val] -> Expr -> Either Text Expr
substitute_vars [Val]
vals (Ky.Expr NonEmpty Call
calls) = forall {a} {b}.
Pretty a =>
[a] -> StateT [a] (ExceptT Text Identity) b -> Either Text b
run [Val]
vals (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Call -> StateT [Val] (ExceptT Text Identity) Call
sub_call NonEmpty Call
calls)
    where
    sub_call :: Call -> StateT [Val] (ExceptT Text Identity) Call
sub_call (Ky.Call Symbol
sym [Term]
args) = 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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Term -> StateT [Val] (ExceptT Text Identity) Term
sub_arg [Term]
args
    sub_arg :: Term -> StateT [Val] (ExceptT Text Identity) Term
sub_arg Term
term = case Term
term of
        Ky.VarTerm (Ky.Var Text
_) -> forall val. val -> Term val
Expr.Literal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Val] (ExceptT Text Identity) Val
pop
        Ky.Literal Val
val -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall val. val -> Term val
Expr.Literal Val
val)
        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 -> StateT [Val] (ExceptT Text Identity) Call
sub_call Call
call
    pop :: StateT [Val] (ExceptT Text Identity) Val
pop = do
        [Val]
vals <- forall s (m :: * -> *). MonadState s m => m s
Monad.State.get
        case [Val]
vals of
            [] -> forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Text
"ran out of vals"
            Val
v : [Val]
vs -> forall s (m :: * -> *). MonadState s m => s -> m ()
Monad.State.put [Val]
vs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Val
v
    run :: [a] -> StateT [a] (ExceptT Text Identity) b -> Either Text b
run [a]
state = forall {a} {b}. Pretty a => Either Text (b, [a]) -> Either Text b
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
Identity.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Monad.State.runStateT [a]
state
    check :: Either Text (b, [a]) -> Either Text b
check (Left Text
e) = forall a b. a -> Either a b
Left Text
e
    check (Right (b
a, [])) = forall a b. b -> Either a b
Right b
a
    check (Right (b
_, [a]
xs)) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"left overs: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [a]
xs

-- | Since I don't have the Sig.Parsers but just the ArgDocs, I can't check the
-- types, but I can have the right doc.  The type will be checked by the calls
-- when I apply them.
--
-- TODO these are all required, but should I support optional args?  But isn't
-- the whole point of doing this in haskell that I don't get tied up in more
-- and more hacky language features?
make_signature :: [(Ky.Var, Expr.Symbol, Int)] -> Sig.Parser [Sig.Arg]
make_signature :: [(Var, Symbol, Int)] -> Parser [Arg]
make_signature [(Var, Symbol, Int)]
vars = [ArgDoc] -> Parser [Arg]
Sig.required_vals (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. ShowVal a => (Var, a, Int) -> ArgDoc
doc [(Var, Symbol, Int)]
vars)
    where
    doc :: (Var, a, Int) -> ArgDoc
doc (Ky.Var Text
var, a
call, Int
argnum) = Derive.ArgDoc
        { arg_name :: ArgName
arg_name = Text -> ArgName
Derive.ArgName Text
var
        , arg_type :: Type
arg_type = Type
ValType.TVal
        , arg_parser :: ArgParser
arg_parser = ArgParser
Derive.Required
        , arg_environ_default :: EnvironDefault
arg_environ_default = EnvironDefault
Derive.Prefixed
        , arg_doc :: Doc
arg_doc = Doc
"Passed to " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc a
call forall a. Semigroup a => a -> a -> a
<> Doc
"'s "
            forall a. Semigroup a => a -> a -> a
<> Int -> Doc
ordinal (Int
argnumforall a. Num a => a -> a -> a
+Int
1) forall a. Semigroup a => a -> a -> a
<> Doc
" argument."
        }

-- TODO implement it
require_val :: Sig.Arg -> Derive.Deriver DeriveT.Val
require_val :: Arg -> Deriver Val
require_val (Sig.SubTrack {}) =
    forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"child tracks don't work for macros yet"
require_val (Sig.LiteralArg Val
arg) = forall (m :: * -> *) a. Monad m => a -> m a
return Val
arg

ordinal :: Int -> Doc.Doc
ordinal :: Int -> Doc
ordinal Int
n = Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showt Int
n forall a. Semigroup a => a -> a -> a
<> case Int
n of
    Int
1 -> Text
"st"; Int
2 -> Text
"nd"; Int
3 -> Text
"rd"; Int
_ -> Text
"th"

make_doc :: Doc.Doc -> Ky.Expr -> Doc.Doc
make_doc :: Doc -> Expr -> Doc
make_doc (Doc.Doc Text
doc) Expr
expr = Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$
    forall a. Textlike a => a -> a -> a
Texts.unlines2 (Text
"A macro for: " forall a. Semigroup a => a -> a -> a
<> Text
expr_doc forall a. Semigroup a => a -> a -> a
<> Text
".") Text
doc
    where (Doc.Doc Text
expr_doc) = forall a. ShowVal a => a -> Doc
ShowVal.doc Expr
expr