-- Copyright 2013 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 FlexibleContexts #-}
-- | This is like "Derive.Call", but higher level.  It has templates for
-- creating calls.
module Derive.Call.Make where
import qualified Util.Doc as Doc
import qualified Util.Texts as Texts
import qualified Derive.Attrs as Attrs
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.Flags as Flags
import qualified Derive.Library as Library
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Signal as Signal


-- | This is a specialization of 'transform_notes' that adds Attributes.
attributed_note :: Module.Module -> Attrs.Attributes
    -> Library.Calls Derive.Note
attributed_note :: Module -> Attributes -> Calls Event
attributed_note Module
module_ Attributes
attrs = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Event
transform_notes Module
module_
    (Text -> CallName
Derive.CallName forall a b. (a -> b) -> a -> b
$ Text
"note with " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
attrs) Tags
Tags.attr
    Doc
"Add attributes to the notes." Parser ()
Sig.no_args
    (\() -> forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs)

-- | This is a specialization of 'transform_notes' that sets an environ value.
environ_note :: Typecheck.ToVal a => Module.Module -> Derive.CallName
    -> Tags.Tags -> Doc.Doc -> Env.Key -> a -> Library.Calls Derive.Note
environ_note :: forall a.
ToVal a =>
Module -> CallName -> Tags -> Doc -> Text -> a -> Calls Event
environ_note Module
module_ CallName
name Tags
tags Doc
doc Text
key a
val =
    forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Event
transform_notes Module
module_ CallName
name Tags
tags Doc
doc Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$
        \() -> forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
key a
val

-- | This is a specialization of 'transform_notes' that sets a control.
control_note :: Module.Module -> Derive.CallName -> ScoreT.Control -> Signal.Y
    -> Library.Calls Derive.Note
control_note :: Module -> CallName -> Control -> Y -> Calls Event
control_note Module
module_ CallName
name Control
control Y
val = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Event
transform_notes Module
module_ CallName
name forall a. Monoid a => a
mempty
    (Doc
"Note with " forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Doc.literal (forall a. ShowVal a => a -> Text
ShowVal.show_val Control
control forall a. Semigroup a => a -> a -> a
<> Text
" = "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Y
val) forall a. Semigroup a => a -> a -> a
<> Doc
".")
    Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$ \() -> forall a. Control -> Y -> Deriver a -> Deriver a
Derive.with_constant_control Control
control Y
val

-- | 'transform_notes_args' without the PassedArgs.
transform_notes :: Module.Module -> Derive.CallName -> Tags.Tags -> Doc.Doc
    -> Sig.Parser a -> (a -> Derive.NoteDeriver -> Derive.NoteDeriver)
    -> Library.Calls Derive.Note
transform_notes :: forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Event
transform_notes Module
module_ CallName
name Tags
tags Doc
transform_doc Parser a
sig a -> NoteDeriver -> NoteDeriver
transform =
    forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> PassedArgs Event -> NoteDeriver -> NoteDeriver)
-> Calls Event
transform_notes_args Module
module_ CallName
name Tags
tags Doc
transform_doc Parser a
sig
        (\a
params PassedArgs Event
_args NoteDeriver
deriver -> a -> NoteDeriver -> NoteDeriver
transform a
params NoteDeriver
deriver)

-- | The generator either derives subs or derives a new Call.note if there are
-- no subs, and then applies the transform.  The transformer call just applies
-- the transform.
transform_notes_args :: Module.Module -> Derive.CallName -> Tags.Tags
    -> Doc.Doc -> Sig.Parser a
    -> (a -> Derive.PassedArgs Score.Event -> Derive.NoteDeriver
        -> Derive.NoteDeriver)
    -> Library.Calls Derive.Note
transform_notes_args :: forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> PassedArgs Event -> NoteDeriver -> NoteDeriver)
-> Calls Event
transform_notes_args Module
module_ CallName
name Tags
tags Doc
transform_doc Parser a
sig a -> PassedArgs Event -> NoteDeriver -> NoteDeriver
transform =
    forall d. Generator d -> Transformer d -> Calls d
Library.Calls Generator Event
generator Transformer Event
transformer
    where
    generator :: Generator Event
generator = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
name (Tags
tags forall a. Semigroup a => a -> a -> a
<> Tags
Tags.subs)
        (Doc
transform_doc forall a. Semigroup a => a -> a -> a
<> Doc
"\n" forall a. Semigroup a => a -> a -> a
<> Doc
generator_doc) 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 Parser a
sig forall a b. (a -> b) -> a -> b
$ \a
params PassedArgs Event
args -> forall d. PassedArgs d -> Deriver [[Event]]
Sub.sub_events PassedArgs Event
args forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            [] -> a -> PassedArgs Event -> NoteDeriver -> NoteDeriver
transform a
params PassedArgs Event
args forall a b. (a -> b) -> a -> b
$ forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall d. PassedArgs d -> NoteDeriver
Call.placed_note PassedArgs Event
args
            [[Event]]
subs -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (a -> PassedArgs Event -> NoteDeriver -> NoteDeriver
transform a
params PassedArgs Event
args forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> NoteDeriver
Sub.derive) [[Event]]
subs
    generator_doc :: Doc
generator_doc = Doc
"If there are notes in child tracks, apply the\
        \ transformation to them. Otherwise apply the transformation to the\
        \ null note call."
    transformer :: Transformer Event
transformer = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
name Tags
tags Doc
transform_doc 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 Parser a
sig forall a b. (a -> b) -> a -> b
$ \a
params PassedArgs Event
args NoteDeriver
deriver -> a -> PassedArgs Event -> NoteDeriver -> NoteDeriver
transform a
params PassedArgs Event
args NoteDeriver
deriver

-- | Create a transformer that just sets an environ value.  This is higher
-- level and more concise than using the @=@ transformer.
environ :: (Typecheck.ToVal val, Derive.Taggable d) =>
    Module.Module -> Env.Key -> Doc.Doc -> Sig.Parser a
    -> (a -> val) -> Derive.Transformer d
environ :: forall val d a.
(ToVal val, Taggable d) =>
Module -> Text -> Doc -> Parser a -> (a -> val) -> Transformer d
environ Module
module_ Text
key Doc
key_doc Parser a
sig a -> val
extract =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ (Text -> CallName
Derive.CallName Text
key) forall a. Monoid a => a
mempty
        (Doc
"Set the " forall a. Semigroup a => a -> a -> a
<> Doc
key_doc forall a. Semigroup a => a -> a -> a
<> Doc
" environ variable.")
    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 Parser a
sig forall a b. (a -> b) -> a -> b
$ \a
val PassedArgs d
_args ->
        forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
key (a -> val
extract a
val)

-- | Make a call that sets an environ key to a specific value.
environ_val :: (ShowVal.ShowVal a, Typecheck.ToVal a, Derive.Taggable d) =>
    Module.Module -> Derive.CallName -> Env.Key -> a -> Doc.Doc
    -> Derive.Transformer d
environ_val :: forall a d.
(ShowVal a, ToVal a, Taggable d) =>
Module -> CallName -> Text -> a -> Doc -> Transformer d
environ_val Module
module_ CallName
name Text
key a
val Doc
extra_doc =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
name forall a. Monoid a => a
mempty (forall a. Textlike a => a -> a -> a
Texts.unwords2 Doc
doc Doc
extra_doc) forall a b. (a -> b) -> a -> b
$
        forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs d
_args -> forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
key a
val
    where
    doc :: Doc
doc = Text -> Doc
Doc.literal (forall a. ShowVal a => a -> Text
ShowVal.show_val Text
key forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val a
val)
        forall a. Semigroup a => a -> a -> a
<> Doc
"."

-- | Make a call that adds a flag.
add_flag :: Module.Module -> Derive.CallName -> Doc.Doc -> Flags.Flags
    -> Derive.Transformer Score.Event
add_flag :: Module -> CallName -> Doc -> Flags -> Transformer Event
add_flag Module
module_ CallName
name Doc
doc Flags
flags =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
name Tags
Tags.postproc Doc
doc forall a b. (a -> b) -> a -> b
$
    forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
_args -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ forall a b. (a -> b) -> a -> b
$ Flags -> Event -> Event
Score.add_flags Flags
flags

-- * modify

-- | Make a modified version of an existing call.  Args are the same.
modify_generator :: Module.Module -> Derive.CallName -> Doc.Doc
    -> Derive.TransformerF a -> Derive.Generator a -> Derive.Generator a
modify_generator :: forall a.
Module
-> CallName -> Doc -> TransformerF a -> Generator a -> Generator a
modify_generator Module
module_ CallName
name Doc
doc TransformerF a
transform =
    forall a b.
Module -> CallName -> Doc -> (a -> b) -> Call a -> Call b
modify_call Module
module_ CallName
name Doc
doc forall a b. (a -> b) -> a -> b
$ \GeneratorFunc a
gfunc -> GeneratorFunc a
gfunc
        { gfunc_f :: GeneratorF a
Derive.gfunc_f = \PassedArgs a
args -> TransformerF a
transform PassedArgs a
args (forall d. GeneratorFunc d -> GeneratorF d
Derive.gfunc_f GeneratorFunc a
gfunc PassedArgs a
args)
        }

-- | Like 'modify_generator', but inherit metadata from the original call.
modify_generator_ :: Doc.Doc
    -> Derive.TransformerF a -> Derive.Generator a -> Derive.Generator a
modify_generator_ :: forall a. Doc -> TransformerF a -> Generator a -> Generator a
modify_generator_ Doc
doc_prefix TransformerF a
transform Generator a
call =
    forall a.
Module
-> CallName -> Doc -> TransformerF a -> Generator a -> Generator a
modify_generator (CallDoc -> Module
Derive.cdoc_module CallDoc
cdoc) (forall func. Call func -> CallName
Derive.call_name Generator a
call)
        (forall a. Textlike a => a -> a -> a
Texts.unlines2 Doc
doc_prefix (CallDoc -> Doc
Derive.cdoc_doc CallDoc
cdoc))
        TransformerF a
transform Generator a
call
    where cdoc :: CallDoc
cdoc = forall func. Call func -> CallDoc
Derive.call_doc Generator a
call

-- | Make a modified version of an existing call.  Args are the same.
modify_transformer :: Module.Module -> Derive.CallName -> Doc.Doc
    -> Derive.TransformerF a -> Derive.Transformer a -> Derive.Transformer a
modify_transformer :: forall a.
Module
-> CallName
-> Doc
-> TransformerF a
-> Transformer a
-> Transformer a
modify_transformer Module
module_ CallName
name Doc
doc TransformerF a
transform =
    forall a b.
Module -> CallName -> Doc -> (a -> b) -> Call a -> Call b
modify_call Module
module_ CallName
name Doc
doc forall a b. (a -> b) -> a -> b
$ \TransformerF a
tfunc PassedArgs a
args -> TransformerF a
transform PassedArgs a
args forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransformerF a
tfunc PassedArgs a
args

modify_transformer_ :: Doc.Doc
    -> Derive.TransformerF a -> Derive.Transformer a -> Derive.Transformer a
modify_transformer_ :: forall a. Doc -> TransformerF a -> Transformer a -> Transformer a
modify_transformer_ Doc
doc_prefix TransformerF a
transform Transformer a
call =
    forall a.
Module
-> CallName
-> Doc
-> TransformerF a
-> Transformer a
-> Transformer a
modify_transformer (CallDoc -> Module
Derive.cdoc_module CallDoc
cdoc) (forall func. Call func -> CallName
Derive.call_name Transformer a
call)
        (forall a. Textlike a => a -> a -> a
Texts.unlines2 Doc
doc_prefix (CallDoc -> Doc
Derive.cdoc_doc CallDoc
cdoc))
        TransformerF a
transform Transformer a
call
    where cdoc :: CallDoc
cdoc = forall func. Call func -> CallDoc
Derive.call_doc Transformer a
call

-- | Modify a generator transformer pair, inheriting metadata.
modify_calls_ :: Doc.Doc
    -> Derive.TransformerF a
    -> Library.Calls a -> Library.Calls a
modify_calls_ :: forall a. Doc -> TransformerF a -> Calls a -> Calls a
modify_calls_ Doc
doc_prefix TransformerF a
transform (Library.Calls Generator a
gen Transformer a
trans) = Library.Calls
    { generator :: Generator a
generator = forall a. Doc -> TransformerF a -> Generator a -> Generator a
modify_generator_ Doc
doc_prefix TransformerF a
transform Generator a
gen
    , transformer :: Transformer a
transformer = forall a. Doc -> TransformerF a -> Transformer a -> Transformer a
modify_transformer_ Doc
doc_prefix TransformerF a
transform Transformer a
trans
    }

modify_call :: Module.Module -> Derive.CallName -> Doc.Doc
    -> (a -> b) -> Derive.Call a -> Derive.Call b
modify_call :: forall a b.
Module -> CallName -> Doc -> (a -> b) -> Call a -> Call b
modify_call Module
module_ CallName
name Doc
doc a -> b
modify Call a
call = Derive.Call
    { call_name :: CallName
call_name = CallName
name
    , call_doc :: CallDoc
call_doc = Derive.CallDoc
        { cdoc_tags :: Tags
cdoc_tags = CallDoc -> Tags
Derive.cdoc_tags (forall func. Call func -> CallDoc
Derive.call_doc Call a
call)
        , cdoc_module :: Module
cdoc_module = Module
module_
        , cdoc_doc :: Doc
cdoc_doc = Doc
doc
        , cdoc_args :: [ArgDoc]
cdoc_args = CallDoc -> [ArgDoc]
Derive.cdoc_args (forall func. Call func -> CallDoc
Derive.call_doc Call a
call)
        }
    , call_func :: b
call_func = a -> b
modify forall a b. (a -> b) -> a -> b
$ forall func. Call func -> func
Derive.call_func Call a
call
    }

-- * val calls

constant_val :: (Typecheck.ToVal a, ShowVal.ShowVal a) =>
    Module.Module -> Derive.CallName -> Doc.Doc -> a -> Derive.ValCall
constant_val :: forall a.
(ToVal a, ShowVal a) =>
Module -> CallName -> Doc -> a -> ValCall
constant_val Module
module_ CallName
name Doc
doc a
val = forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
module_  CallName
name forall a. Monoid a => a
mempty
    (forall a. Textlike a => a -> a -> a
Texts.unlines2 Doc
doc (Doc
"Constant: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc a
val)) forall a b. (a -> b) -> a -> b
$
    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 (m :: * -> *) a. Monad m => a -> m a
return a
val

-- | Make a new ValCall from an existing one, by mapping over its output.
modify_vcall :: Derive.ValCall -> Module.Module -> Derive.CallName -> Doc.Doc
    -> (DeriveT.Val -> DeriveT.Val) -> Derive.ValCall
modify_vcall :: ValCall -> Module -> CallName -> Doc -> (Val -> Val) -> ValCall
modify_vcall ValCall
vcall Module
module_ CallName
name Doc
doc Val -> Val
f = Derive.ValCall
    { vcall_name :: CallName
vcall_name = CallName
name
    , vcall_doc :: CallDoc
vcall_doc = Derive.CallDoc
        { cdoc_tags :: Tags
cdoc_tags = CallDoc -> Tags
Derive.cdoc_tags (ValCall -> CallDoc
Derive.vcall_doc ValCall
vcall)
        , cdoc_module :: Module
cdoc_module = Module
module_
        , cdoc_doc :: Doc
cdoc_doc = Doc
doc
        , cdoc_args :: [ArgDoc]
cdoc_args = CallDoc -> [ArgDoc]
Derive.cdoc_args (ValCall -> CallDoc
Derive.vcall_doc ValCall
vcall)
        }
    , vcall_call :: PassedArgs Tagged -> Deriver Val
vcall_call = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Val -> Val
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValCall -> PassedArgs Tagged -> Deriver Val
Derive.vcall_call ValCall
vcall
    }