-- 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

-- | Export 'c_equal' call, which implements @=@.
--
-- The equal call is heavily overloaded because I want to reuse the nice infix
-- syntax.  Unfortunately it results in lots of cryptic prefixes.  Is it worth
-- it?
module Derive.C.Prelude.Equal (
    library, c_equal
    , transform_expr
) where
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Derive.Args as Args
import qualified Derive.Call.Module as Module
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.Deriver.Internal as Internal
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Parse as Parse
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 Derive.ValType as ValType

import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal
import qualified Ui.Id as Id

import           Global


-- * note

library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators [(Symbol
"=", Generator Note
c_equal_generator)]
    , (forall d. CallableExpr d => [(Symbol, Transformer d)]) -> Library
Library.poly_transformers
        [ (Symbol
"=", forall d. CallableExpr d => Transformer d
c_equal)
        , (Symbol
"default-merge", forall d. Taggable d => Transformer d
c_default_merge)
        ]
    ]

-- * util

-- | Parse an expression containing only equal calls and turn it into a
-- transformer.  'Eval.eval_transform_expr' is more general, but only
-- transforms Streams, because most transforms work with a stream.  So by
-- having a more restrictive input, this can have a more general output:
-- contravariance I guess?
transform_expr :: Text -> Derive.Deriver a -> Derive.Deriver a
transform_expr :: forall a. Text -> Deriver a -> Deriver a
transform_expr Text
expr Deriver a
deriver = do
    Expr
parsed <- 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
$ Text -> Either Text Expr
Parse.parse_expr Text
expr
    [Deriver a -> Deriver a]
transforms <- if forall a. Expr a -> Bool
is_empty_expr Expr
parsed
        then forall (m :: * -> *) a. Monad m => a -> m a
return []
        else forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. Call -> Deriver State Error (Deriver a -> Deriver a)
apply forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
parsed
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) Deriver a
deriver [Deriver a -> Deriver a]
transforms
    where
    apply :: Call -> Deriver State Error (Deriver a -> Deriver a)
apply Call
expr = do
        (Text
lhs, Val
rhs) <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require
            (Text
"expected an assignment: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Call
expr)
            (Call -> Maybe (Text, Val)
equal_expr Call
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
$ forall a.
Merge -> Text -> Val -> Either Text (Deriver a -> Deriver a)
parse_equal Merge
Set Text
lhs Val
rhs

is_empty_expr :: Expr.Expr a -> Bool
is_empty_expr :: forall a. Expr a -> Bool
is_empty_expr (Expr.Call Symbol
"" [] :| []) = Bool
True
is_empty_expr NonEmpty (Call a)
_ = Bool
False

equal_expr :: DeriveT.Call -> Maybe (Text, DeriveT.Val)
equal_expr :: Call -> Maybe (Text, Val)
equal_expr (Expr.Call (Expr.Symbol Text
"=")
        [Expr.Literal (DeriveT.VStr (Expr.Str Text
lhs)), Expr.Literal Val
val]) =
    forall a. a -> Maybe a
Just (Text
lhs, Val
val)
equal_expr Call
_ = forall a. Maybe a
Nothing

-- * implementation

c_equal :: Derive.CallableExpr d => Derive.Transformer d
c_equal :: forall d. CallableExpr d => Transformer d
c_equal = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"equal" Tags
Tags.subs Doc
equal_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 (Text, Val, Merge)
equal_args forall a b. (a -> b) -> a -> b
$ \(Text
lhs, Val
rhs, Merge
merge) PassedArgs d
_args Deriver (Stream d)
deriver -> do
        Deriver (Stream d) -> Deriver (Stream d)
transform <- 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
$ forall a.
Merge -> Text -> Val -> Either Text (Deriver a -> Deriver a)
parse_equal Merge
merge Text
lhs Val
rhs
        Deriver (Stream d) -> Deriver (Stream d)
transform Deriver (Stream d)
deriver

c_equal_generator :: Derive.Generator Derive.Note
c_equal_generator :: Generator Note
c_equal_generator = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"equal" Tags
Tags.subs
    Doc
"Similar to the transformer, this will evaluate the notes below in\
    \ a transformed environ." 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 (Text, Val, Merge)
equal_args forall a b. (a -> b) -> a -> b
$ \(Text
lhs, Val
rhs, Merge
merge) PassedArgs Note
args -> do
        Deriver (Stream Note) -> Deriver (Stream Note)
transform <- 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
$ forall a.
Merge -> Text -> Val -> Either Text (Deriver a -> Deriver a)
parse_equal Merge
merge Text
lhs Val
rhs
        Deriver (Stream Note) -> Deriver (Stream Note)
transform forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Deriver (Stream Note)
Sub.derive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall d. PassedArgs d -> Deriver [[Event]]
Sub.sub_events PassedArgs Note
args

equal_args :: Sig.Parser (Text, DeriveT.Val, Merge)
equal_args :: Parser (Text, Val, Merge)
equal_args = (,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"lhs" EnvironDefault
Sig.None
        Doc
"Assign to this. This looks like a Str, but\
        \ can actualy contain any characters except `=`, due to the special\
        \ infix parsing for `=`. Symbolic prefixes determine what is\
        \ assigned, and the valid types for the rhs."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"rhs" EnvironDefault
Sig.None Doc
"Source of the assignment."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Symbol -> Merge
parse_merge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"merge" (Text
"set" :: Text) Doc
merge_doc)

merge_doc :: Doc.Doc
merge_doc :: Doc
merge_doc = Doc
"Merge operator. This can be `default` to use the default for the\
    \ control, `set` to replace the old signal, or one of the operators from\
    \ 'Derive.Deriver.Monad.mergers': "
    forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
Doc.commas (forall a b. (a -> b) -> [a] -> [b]
map forall a. ShowVal a => a -> Doc
ShowVal.doc (forall k a. Map k a -> [k]
Map.keys Map Symbol Merger
Derive.mergers)) forall a. Semigroup a => a -> a -> a
<> Doc
"."
    forall a. Semigroup a => a -> a -> a
<> Doc
" There are also symbolic aliases, to support `=+` syntax: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty Map Symbol Symbol
symbol_to_merge

data Merge = Default | Set | Merge Expr.Symbol deriving (Int -> Merge -> ShowS
[Merge] -> ShowS
Merge -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Merge] -> ShowS
$cshowList :: [Merge] -> ShowS
show :: Merge -> String
$cshow :: Merge -> String
showsPrec :: Int -> Merge -> ShowS
$cshowsPrec :: Int -> Merge -> ShowS
Show)

instance ShowVal.ShowVal Merge where
    show_val :: Merge -> Text
show_val Merge
Default = Text
"default"
    show_val Merge
Set = Text
"set"
    show_val (Merge Symbol
sym) = forall a. ShowVal a => a -> Text
ShowVal.show_val Symbol
sym

parse_merge :: Expr.Symbol -> Merge
parse_merge :: Symbol -> Merge
parse_merge Symbol
name
    | Symbol
name forall a. Eq a => a -> a -> Bool
== Symbol
"set" = Merge
Set
    | Symbol
name forall a. Eq a => a -> a -> Bool
== Symbol
"default" = Merge
Default
    | Bool
otherwise = Symbol -> Merge
Merge forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Symbol
name Symbol
name Map Symbol Symbol
symbol_to_merge

symbol_to_merge :: Map Expr.Symbol Expr.Symbol
symbol_to_merge :: Map Symbol Symbol
symbol_to_merge = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Symbol
"+", Symbol
"add")
    , (Symbol
"-", Symbol
"sub")
    , (Symbol
"*", Symbol
"mul")
    , (Symbol
"@", Symbol
"scale")
    ]

equal_doc :: Doc.Doc
equal_doc :: Doc
equal_doc =
    Doc
"Evaluate the deriver with a value set. Special parser support means this\
    \ can be called infix.  The arguments can take many forms to set different\
    \ kinds of values.\
    \\nSet an environ value by setting a plain symbol or unset it by assigning\
    \ to `_`: `x = 42` or `x = _`.\
    \\nPrefixes:\
    \\n- `>>` - Create a note transformer, whose name will be prefixed with\
    \ `>`.  This is used to set an instrument transformer, which can apply\
    \ a transformer when an instrument is set by the title of a note track, as\
    \ implemented by by `note-track`.\
    \\n- `-val` - Bind a val call.\
    \\n- `^note`, `*pitch`, `.control` - Bind the respective call type\
    \ generator.\
    \\n- `^-note`, `*-pitch`, `.-control` - As above, but bind transformer.\
    \\n- `>alias = >inst` - alias instrument name\
    \\nE.g.: set note generator: `^phrase = some-block`,\
    \ note transformer: `^-mute = +mute+loose`,\
    \ control transfomrer: `.-i = t`, val call: `-4c = (5c)`.\
    \\nYou can bypass all this cryptic prefix garbage by using a `ky` file.\
    \ It has more space available so it can use a more readable syntax.\
    \\nIf you bind a call to a quoted expression, this creates a new\
    \ call: `^abc = \"(a b c)` will create a `abc` call, which is a macro for\
    \ `a b c`. The created call does not take arguments.\
    \\nSet the default pitch signal with `#`, e.g. `# = (4c)` or `# = 45nn`.\
    \ Control signal assignment also supports the same merge functions as the\
    \ control track: `a = .5 add` or `a = %b add`.  However, the second example\
    \ throws an error if `%b` is a ControlFunction. `a = .5 default` will\
    \ combine with `a`'s default merge function. Assigning to `_` unsets the\
    \ control, and any ControlFunction.\
    \\nThe `=` operator can be suffixed with symbol, which will become the last\
    \ argument, so `%x=+1` becomes `%x = 1 '+'`.  Note that the order\
    \ is backwards from the usual `+=`, which is ultimately because the first\
    \ word can have almost any character except space and `=`. Also, `x=-1` is\
    \ ambiguous, and parsed as `x =- 1`."
    -- Previously > was for binding note calls, but that was taken by
    -- instrument aliasing.  ^ at least looks like a rotated >.

parse_equal :: Merge -> Text -> DeriveT.Val
    -> Either Text (Derive.Deriver a -> Derive.Deriver a)
parse_equal :: forall a.
Merge -> Text -> Val -> Either Text (Deriver a -> Deriver a)
parse_equal Merge
Set Text
lhs Val
rhs
    -- Assign to call.
    | Just Text
new <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"^" Text
lhs = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        forall d1 d2 a.
(CallableExpr d1, CallableExpr d2) =>
Text
-> Val
-> Lens Scopes (ScopePriority (Generator d1))
-> Lens Scopes (ScopePriority (Transformer d2))
-> Deriver a
-> Deriver a
override_call Text
new Val
rhs
            (forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> gen
Derive.s_generatorforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {note} {control} {pitch}. Scope note control pitch :-> note
Derive.s_note)
            (forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> trans
Derive.s_transformerforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {note} {control} {pitch}. Scope note control pitch :-> note
Derive.s_note)
    | Just Text
new <- Text -> Text -> Maybe Text
Text.stripPrefix Text
">>" Text
lhs = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        forall d a.
CallableExpr d =>
Text
-> Val
-> Lens Scopes (ScopePriority (Transformer d))
-> Deriver a
-> Deriver a
override_transformer (Text
">" forall a. Semigroup a => a -> a -> a
<> Text
new) Val
rhs
            (forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> trans
Derive.s_transformerforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {note} {control} {pitch}. Scope note control pitch :-> note
Derive.s_note)
    | Just Text
new <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"*" Text
lhs = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        forall d1 d2 a.
(CallableExpr d1, CallableExpr d2) =>
Text
-> Val
-> Lens Scopes (ScopePriority (Generator d1))
-> Lens Scopes (ScopePriority (Transformer d2))
-> Deriver a
-> Deriver a
override_call Text
new Val
rhs
            (forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> gen
Derive.s_generatorforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {note} {control} {pitch}. Scope note control pitch :-> pitch
Derive.s_pitch)
            (forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> trans
Derive.s_transformerforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {note} {control} {pitch}. Scope note control pitch :-> pitch
Derive.s_pitch)
    | Just Text
new <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"." Text
lhs = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        forall d1 d2 a.
(CallableExpr d1, CallableExpr d2) =>
Text
-> Val
-> Lens Scopes (ScopePriority (Generator d1))
-> Lens Scopes (ScopePriority (Transformer d2))
-> Deriver a
-> Deriver a
override_call Text
new Val
rhs
            (forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> gen
Derive.s_generatorforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {note} {control} {pitch}.
Scope note control pitch :-> control
Derive.s_control)
            (forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> trans
Derive.s_transformerforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {note} {control} {pitch}.
Scope note control pitch :-> control
Derive.s_control)
    | Just Text
new <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"-" Text
lhs = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Text -> Val -> Deriver a -> Deriver a
override_val_call Text
new Val
rhs
parse_equal Merge
Set Text
lhs Val
rhs
    -- Create instrument alias.
    | Just Text
new <- Text -> Text -> Maybe Text
Text.stripPrefix Text
">" Text
lhs = case Val
rhs of
        DeriveT.VStr (Expr.Str Text
inst) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
            forall a. Instrument -> Instrument -> Deriver a -> Deriver a
Derive.with_instrument_alias (Text -> Instrument
ScoreT.Instrument Text
new)
                (Text -> Instrument
ScoreT.Instrument Text
inst)
        Val
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"aliasing an instrument expected an instrument rhs, got "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.specific_type_of Val
rhs)
-- TODO should I centralize the parsing of #?  Or is equal the only place that
-- needs this notation where # is state_pitch?  I used to parse a VPControlRef
parse_equal Merge
Set Text
"#" Val
rhs = case Val
rhs of
    DeriveT.VPitch Pitch
p -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Pitch -> Deriver a -> Deriver a
Derive.with_pitch (Pitch -> Pitch
PSignal.constant Pitch
p)
    DeriveT.VPSignal Pitch
sig -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Pitch -> Deriver a -> Deriver a
Derive.with_pitch Pitch
sig
    -- I could also convert a signal, but not sure it's useful.
    DeriveT.VSignal (ScoreT.Typed Type
ScoreT.Nn Control
sig)
        | Just Y
nn <- forall {k} (kind :: k). Signal kind -> Maybe Y
Signal.constant_val Control
sig ->
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Pitch -> Deriver a -> Deriver a
Derive.with_pitch
                (Pitch -> Pitch
PSignal.constant (NoteNumber -> Pitch
PSignal.nn_pitch (forall a. Real a => a -> NoteNumber
Pitch.nn Y
nn)))
    Val
DeriveT.VNotGiven -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Pitch -> Deriver a -> Deriver a
Derive.with_pitch forall a. Monoid a => a
mempty
    DeriveT.VPControlRef PControlRef
ref -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \Deriver a
deriver -> do
        Pitch
sig <- PControlRef -> Deriver Pitch
Typecheck.resolve_pitch_ref PControlRef
ref
        forall a. Pitch -> Deriver a -> Deriver a
Derive.with_pitch Pitch
sig Deriver a
deriver
    Val
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"binding a pitch signal expected a pitch, pitch"
        forall a. Semigroup a => a -> a -> a
<> Text
" signal, or nn, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.specific_type_of Val
rhs)
parse_equal Merge
Set Text
lhs Val
rhs
    | Bool -> Bool
not (Text -> Bool
Id.valid_symbol Text
lhs) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        Text
"tried to assign to invalid symbol name: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Text
lhs
    | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
lhs Val
rhs
-- if rhs is a signal or number, then merge is ok
parse_equal Merge
merge Text
lhs Val
rhs = case Val
rhs of
    DeriveT.VSignal Typed Control
sig -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall {b}. Typed Control -> Deriver b -> Deriver b
merge_signal Typed Control
sig
    Val
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"merge is only supported for numeric types, tried to merge "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.specific_type_of Val
rhs) forall a. Semigroup a => a -> a -> a
<> Text
" with "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Merge
merge
    where
    merge_signal :: Typed Control -> Deriver b -> Deriver b
merge_signal Typed Control
sig Deriver b
deriver = do
        Merger
merger <- Control -> Merge -> Deriver Merger
get_merger Control
control Merge
merge
        forall a.
Merger -> Control -> Typed Control -> Deriver a -> Deriver a
Derive.with_merged_control Merger
merger Control
control Typed Control
sig Deriver b
deriver
    control :: Control
control = Text -> Control
ScoreT.Control Text
lhs

-- | Unlike 'Derive.MergeDefault', the default is Derive.Set.
get_merger :: ScoreT.Control -> Merge -> Derive.Deriver Derive.Merger
get_merger :: Control -> Merge -> Deriver Merger
get_merger Control
control = \case
    Merge
Set -> forall (m :: * -> *) a. Monad m => a -> m a
return Merger
Derive.Set
    Merge
Default -> Control -> Deriver Merger
Derive.get_default_merger Control
control
    Merge Symbol
merge -> Symbol -> Deriver Merger
Derive.get_control_merge Symbol
merge

-- | Look up a call with the given Symbol and add it as an override to the
-- scope given by the lenses.  I wanted to pass just one lens, but apparently
-- they're not sufficiently polymorphic.
override_call :: (Derive.CallableExpr d1, Derive.CallableExpr d2)
    => Text -> DeriveT.Val
    -> Lens Derive.Scopes (Derive.ScopePriority (Derive.Generator d1))
    -> Lens Derive.Scopes (Derive.ScopePriority (Derive.Transformer d2))
    -> Derive.Deriver a -> Derive.Deriver a
override_call :: forall d1 d2 a.
(CallableExpr d1, CallableExpr d2) =>
Text
-> Val
-> Lens Scopes (ScopePriority (Generator d1))
-> Lens Scopes (ScopePriority (Transformer d2))
-> Deriver a
-> Deriver a
override_call Text
lhs Val
rhs Lens Scopes (ScopePriority (Generator d1))
generator Lens Scopes (ScopePriority (Transformer d2))
transformer Deriver a
deriver
    | Just Text
stripped <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"-" Text
lhs =
        forall d a.
CallableExpr d =>
Text
-> Val
-> Lens Scopes (ScopePriority (Transformer d))
-> Deriver a
-> Deriver a
override_transformer Text
stripped Val
rhs Lens Scopes (ScopePriority (Transformer d2))
transformer Deriver a
deriver
    | Bool
otherwise = Generator d1 -> Deriver a
override_generator_scope
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall call.
Callable call =>
(Quoted -> call) -> Val -> Deriver call
resolve_source forall d. CallableExpr d => Quoted -> Generator d
quoted_generator Val
rhs
    where
    override_generator_scope :: Generator d1 -> Deriver a
override_generator_scope Generator d1
call = forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
Derive.with_scopes Scopes -> Scopes
add Deriver a
deriver
        where
        add :: Scopes -> Scopes
add = Lens Scopes (ScopePriority (Generator d1))
generator forall f a. Lens f a -> (a -> a) -> f -> f
%= forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
Derive.add_priority CallPriority
Derive.PrioOverride
            (forall call. Symbol -> call -> CallMap call
Derive.single_call (Text -> Symbol
Expr.Symbol Text
lhs) Generator d1
call)

-- | Make an expression into a transformer and stick it into the
-- 'Derive.PrioOverride' slot.
override_transformer :: Derive.CallableExpr d => Text -> DeriveT.Val
    -> Lens Derive.Scopes (Derive.ScopePriority (Derive.Transformer d))
    -> Derive.Deriver a -> Derive.Deriver a
override_transformer :: forall d a.
CallableExpr d =>
Text
-> Val
-> Lens Scopes (ScopePriority (Transformer d))
-> Deriver a
-> Deriver a
override_transformer Text
lhs Val
rhs Lens Scopes (ScopePriority (Transformer d))
transformer Deriver a
deriver =
    Transformer d -> Deriver a
override_scope forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall call.
Callable call =>
(Quoted -> call) -> Val -> Deriver call
resolve_source forall d. CallableExpr d => Quoted -> Transformer d
quoted_transformer Val
rhs
    where
    override_scope :: Transformer d -> Deriver a
override_scope Transformer d
call = forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
Derive.with_scopes
        (Lens Scopes (ScopePriority (Transformer d))
transformer forall f a. Lens f a -> (a -> a) -> f -> f
%= forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
Derive.add_priority CallPriority
Derive.PrioOverride
            (forall call. Symbol -> call -> CallMap call
Derive.single_call (Text -> Symbol
Expr.Symbol Text
lhs) Transformer d
call))
        Deriver a
deriver

override_val_call :: Text -> DeriveT.Val -> Derive.Deriver a
    -> Derive.Deriver a
override_val_call :: forall a. Text -> Val -> Deriver a -> Deriver a
override_val_call Text
lhs Val
rhs Deriver a
deriver = do
    ValCall
call <- forall call.
Callable call =>
(Quoted -> call) -> Val -> Deriver call
resolve_source Quoted -> ValCall
quoted_val_call Val
rhs
    let add :: ScopesT gen trans track (ScopePriority ValCall)
-> ScopesT gen trans track (ScopePriority ValCall)
add = forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> val
Derive.s_val forall f a. Lens f a -> (a -> a) -> f -> f
%= forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
Derive.add_priority CallPriority
Derive.PrioOverride
            (forall call. Symbol -> call -> CallMap call
Derive.single_call (Text -> Symbol
Expr.Symbol Text
lhs) ValCall
call)
    forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
Derive.with_scopes forall {gen} {trans} {track}.
ScopesT gen trans track (ScopePriority ValCall)
-> ScopesT gen trans track (ScopePriority ValCall)
add Deriver a
deriver

-- | A VQuoted becomes a call, a Str is expected to name a call, and
-- everything else is turned into a Str via ShowVal.  This will cause
-- a parse error for un-showable Vals, but what else is new?
resolve_source :: Derive.Callable call => (DeriveT.Quoted -> call)
    -> DeriveT.Val -> Derive.Deriver call
resolve_source :: forall call.
Callable call =>
(Quoted -> call) -> Val -> Deriver call
resolve_source Quoted -> call
make_call Val
rhs = case Val
rhs of
    DeriveT.VQuoted Quoted
quoted -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Quoted -> call
make_call Quoted
quoted
    DeriveT.VStr (Expr.Str Text
sym) -> forall call. Callable call => Symbol -> Deriver call
get_call (Text -> Symbol
Expr.Symbol Text
sym)
    Val
_ -> forall call. Callable call => Symbol -> Deriver call
get_call (Text -> Symbol
Expr.Symbol (forall a. ShowVal a => a -> Text
ShowVal.show_val Val
rhs))

get_call :: forall call. Derive.Callable call => Expr.Symbol
    -> Derive.Deriver call
get_call :: forall call. Callable call => Symbol -> Deriver call
get_call Symbol
sym = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text -> Symbol -> Text
Eval.unknown_symbol Text
name Symbol
sym) forall (m :: * -> *) a. Monad m => a -> m a
return
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall call. Callable call => Symbol -> Deriver (Maybe call)
Derive.lookup_call Symbol
sym
    where name :: Text
name = forall call. Callable call => Proxy call -> Text
Derive.callable_name (forall {k} (t :: k). Proxy t
Proxy :: Proxy call)


-- * quoted

-- | Create a new call from a quoted expression.  This is flirting with
-- function definiion, but is really just macro expansion, with all the
-- variable capture problems implied.  But since the only variables I have are
-- calls maybe it's not so bad.
quoted_generator :: Derive.CallableExpr d => DeriveT.Quoted
    -> Derive.Generator d
quoted_generator :: forall d. CallableExpr d => Quoted -> Generator d
quoted_generator quoted :: Quoted
quoted@(DeriveT.Quoted Expr
expr) =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
quoted_module CallName
"quoted-call" forall a. Monoid a => a
mempty
    (Doc
"Created from expression: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Quoted
quoted)
    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 d
args -> forall d.
CallableExpr d =>
Bool -> Context d -> Expr -> Deriver (Stream d)
Eval.eval_expr Bool
True (forall a. PassedArgs a -> Context a
Args.context PassedArgs d
args) Expr
expr

quoted_transformer :: Derive.CallableExpr d
    => DeriveT.Quoted -> Derive.Transformer d
quoted_transformer :: forall d. CallableExpr d => Quoted -> Transformer d
quoted_transformer quoted :: Quoted
quoted@(DeriveT.Quoted Expr
expr) =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
quoted_module CallName
"quoted-call" forall a. Monoid a => a
mempty
    (Doc
"Created from expression: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Quoted
quoted)
    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 Deriver (Stream d)
deriver ->
        forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> [Call] -> Deriver (Stream d) -> Deriver (Stream d)
Eval.eval_transformers (forall a. PassedArgs a -> Context a
Args.context PassedArgs d
args) (forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
expr)
            Deriver (Stream d)
deriver

quoted_val_call :: DeriveT.Quoted -> Derive.ValCall
quoted_val_call :: Quoted -> ValCall
quoted_val_call Quoted
quoted = forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
quoted_module CallName
"quoted-call" forall a. Monoid a => a
mempty
    (Doc
"Created from expression: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Quoted
quoted)
    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 -> do
        Term Val
call <- case Quoted
quoted of
            DeriveT.Quoted (Call
call :| []) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall val. Call val -> Term val
Expr.ValCall Call
call
            Quoted
_ -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$
                Text
"expected a val call, but got a full expression: "
                forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Quoted
quoted
        forall a. Taggable a => Context a -> Term Val -> Deriver Val
Eval.eval (forall a. PassedArgs a -> Context a
Args.context PassedArgs Tagged
args) Term Val
call

-- | Pseudo-module for val calls generated from a quoted expression.
quoted_module :: Module.Module
quoted_module :: Module
quoted_module = Module
"quoted"


-- * other

c_default_merge :: Derive.Taggable d => Derive.Transformer d
c_default_merge :: forall d. Taggable d => Transformer d
c_default_merge = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"default-merge" forall a. Monoid a => a
mempty
    Doc
"Set the default merge operators for controls. These apply when the\
    \ control track doesn't have an explicit operator."
    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 ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Symbol -> Merge
parse_merge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"merge" Doc
merge_doc)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. NonEmpty a -> [a]
NonEmpty.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"control" Doc
"Control names.")
    ) forall a b. (a -> b) -> a -> b
$ \(Merge
merge, [Control]
controls) PassedArgs d
_args Deriver (Stream d)
deriver -> do
        [Merger]
mergers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Control
c -> Control -> Merge -> Deriver Merger
get_merger Control
c Merge
merge) [Control]
controls
        forall a. Map Control Merger -> Deriver a -> Deriver a
Internal.with_default_merge (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Control]
controls [Merger]
mergers))
            Deriver (Stream d)
deriver