-- Copyright 2014 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 RankNTypes #-}
-- | Evaluate tracklang expressions.
module Derive.Eval (
    -- * eval / apply
    eval_toplevel, eval_quoted, eval_quoted_normalized, eval_expr_val
    -- ** generator
    , apply_generator
    -- ** transformer
    , eval_transformers, eval_transform_expr
    , apply_transformer, apply_transformers
    , eval_quoted_transformers
    -- ** val calls
    , eval, apply
    , get_val_call

    -- * lookup call
    , get_generator, get_transformer, get_track_call
    , unknown_symbol, call_to_block_id, block_id_to_call
    -- ** relative calls
    , is_relative, make_relative, parse_relative_id

    -- * util
    , eval_one, eval_one_call, eval_one_at
    , eval_event, reapply_generator, reapply_generator_normalized
    , reapply, reapply_call, eval_pitch, eval_note, apply_pitch
    , eval_expr
) where
import qualified Data.Char as Char
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text

import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Expr as Expr
import qualified Derive.PSignal as PSignal
import qualified Derive.Parse as Parse
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

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

import           Global
import           Types


-- * eval / apply

-- | Apply a toplevel expression.
{-# SCC eval_toplevel #-}
eval_toplevel :: Derive.CallableExpr d => Derive.Context d
    -> DeriveT.Expr -> Derive.Deriver (Stream.Stream d)
eval_toplevel :: forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
eval_toplevel Context d
ctx Expr
expr =
    forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> [Call] -> Deriver (Stream d) -> Deriver (Stream d)
eval_transformers Context d
ctx [Call]
transform_calls (forall d.
(Callable (Generator d), Taggable d) =>
Context d -> Call -> Deriver (Stream d)
eval_generator Context d
ctx Call
generator_call)
    where ([Call]
transform_calls, Call
generator_call) = forall val. Expr val -> ([Call val], Call val)
Expr.split Expr
expr

eval_quoted :: Derive.CallableExpr d => Derive.Context d -> DeriveT.Quoted
    -> Derive.Deriver (Stream.Stream d)
eval_quoted :: forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
eval_quoted Context d
ctx (DeriveT.Quoted Expr
expr) = forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
eval_toplevel Context d
ctx Expr
expr

-- | This is like 'eval_quoted', except that the 'Derive.ctx_event' is set to
-- (0, 1) normalized time.  This is important if you want to place the
-- resulting deriver.  Otherwise, you can use eval_quoted and the event's
-- position will fall through to the callee.
--
-- TODO this awkwardness is because events evaluate in track time, not in
-- normalized time.  Details in "Derive.EvalTrack".
eval_quoted_normalized :: Derive.CallableExpr d => Derive.Context d
    -> DeriveT.Quoted -> Derive.Deriver (Stream.Stream d)
eval_quoted_normalized :: forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
eval_quoted_normalized = forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
eval_quoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall val. Context val -> Context val
normalize_event

normalize_event :: Derive.Context val -> Derive.Context val
normalize_event :: forall val. Context val -> Context val
normalize_event Context val
ctx = Context val
ctx
    { ctx_event :: Event
Derive.ctx_event = ScoreTime -> ScoreTime -> Event -> Event
Event.place ScoreTime
0 ScoreTime
1 (forall val. Context val -> Event
Derive.ctx_event Context val
ctx)
    , ctx_prev_events :: [Event]
Derive.ctx_prev_events = []
    , ctx_next_events :: [Event]
Derive.ctx_next_events = []
    }

-- | Eval a Expr MiniVal, which is produced by 'Expr.ToExpr'.
eval_expr_val :: Derive.CallableExpr d => Derive.Context d
    -> Expr.Expr Expr.MiniVal -> Derive.Deriver (Stream.Stream d)
eval_expr_val :: forall d.
CallableExpr d =>
Context d -> Expr MiniVal -> Deriver (Stream d)
eval_expr_val Context d
ctx Expr MiniVal
expr = forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
eval_toplevel Context d
ctx (Expr MiniVal -> Expr
convert_minival Expr MiniVal
expr)

-- TODO find a better place for this, or get rid of MiniVal
convert_minival :: Expr.Expr Expr.MiniVal -> DeriveT.Expr
convert_minival :: Expr MiniVal -> Expr
convert_minival = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \case
    Expr.VNum Typed Y
v -> Typed Control -> Val
DeriveT.VSignal forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Y -> Signal kind
Signal.constant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Y
v
    Expr.VStr Str
v -> Str -> Val
DeriveT.VStr Str
v

-- ** generator

{-# SCC eval_generator #-}
eval_generator :: (Derive.Callable (Derive.Generator d), Derive.Taggable d)
    => Derive.Context d -> DeriveT.Call -> Derive.Deriver (Stream.Stream d)
eval_generator :: forall d.
(Callable (Generator d), Taggable d) =>
Context d -> Call -> Deriver (Stream d)
eval_generator Context d
ctx (Expr.Call Symbol
sym [Term Val]
args) = do
    [Val]
vals <- 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 Val -> Deriver Val
eval Context d
ctx) [Term Val]
args
    Generator d
call <- forall d. Callable (Generator d) => Symbol -> Deriver (Generator d)
get_generator Symbol
sym
    forall d. Context d -> Generator d -> [Val] -> Deriver (Stream d)
apply_generator Context d
ctx Generator d
call [Val]
vals

-- | Like 'eval_generator', but for when the args are already parsed and
-- evaluated.  This is useful when one generator wants to dispatch to another.
{-# SCC apply_generator #-}
apply_generator :: Derive.Context d -> Derive.Generator d -> [DeriveT.Val]
    -> Derive.Deriver (Stream.Stream d)
apply_generator :: forall d. Context d -> Generator d -> [Val] -> Deriver (Stream d)
apply_generator Context d
ctx Generator d
call [Val]
args = do
    let passed :: PassedArgs d
passed = Derive.PassedArgs
            { passed_vals :: [Val]
Derive.passed_vals = [Val]
args
            , passed_call_name :: CallName
Derive.passed_call_name = forall func. Call func -> CallName
Derive.call_name Generator d
call
            , passed_ctx :: Context d
Derive.passed_ctx = Context d
ctx
            }
    Mode
mode <- Deriver Mode
Derive.get_mode
    forall a. CallName -> Deriver a -> Deriver a
Internal.with_stack_call (forall func. Call func -> CallName
Derive.call_name Generator d
call) forall a b. (a -> b) -> a -> b
$ case Mode
mode of
        Mode
Derive.ScoreDurationQuery -> do
            CallDuration ScoreTime
dur <- forall d.
GeneratorFunc d -> PassedArgs d -> Deriver (CallDuration ScoreTime)
Derive.gfunc_score_duration (forall func. Call func -> func
Derive.call_func Generator d
call) PassedArgs d
passed
            CallDuration ScoreTime -> Deriver ()
set_score_duration CallDuration ScoreTime
dur
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty
        Mode
Derive.RealDurationQuery -> do
            CallDuration RealTime
dur <- forall d.
GeneratorFunc d -> PassedArgs d -> Deriver (CallDuration RealTime)
Derive.gfunc_real_duration (forall func. Call func -> func
Derive.call_func Generator d
call) PassedArgs d
passed
            CallDuration RealTime -> Deriver ()
set_real_duration CallDuration RealTime
dur
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty
        Mode
_ -> do
            -- Ensure a unique serial number for each generator call, as
            -- documneted in 'Stack.Serial'.
            Serial
serial <- forall st a err. (st -> a) -> Deriver st err a
Derive.gets forall a b. (a -> b) -> a -> b
$
                Threaded -> Serial
Derive.state_event_serial forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Threaded
Derive.state_threaded
            forall a. Serial -> Deriver a -> Deriver a
Internal.with_stack_serial Serial
serial forall a b. (a -> b) -> a -> b
$
                forall d. GeneratorFunc d -> GeneratorF d
Derive.gfunc_f (forall func. Call func -> func
Derive.call_func Generator d
call) PassedArgs d
passed

-- | See 'Derive.CallDuration' for details.
set_score_duration :: Derive.CallDuration ScoreTime -> Derive.Deriver ()
set_score_duration :: CallDuration ScoreTime -> Deriver ()
set_score_duration CallDuration ScoreTime
dur = (Collect -> Collect) -> Deriver ()
Internal.modify_collect forall a b. (a -> b) -> a -> b
$ \Collect
collect ->
    Collect
collect { collect_score_duration :: CallDuration ScoreTime
Derive.collect_score_duration = CallDuration ScoreTime
dur }

set_real_duration :: Derive.CallDuration RealTime -> Derive.Deriver ()
set_real_duration :: CallDuration RealTime -> Deriver ()
set_real_duration CallDuration RealTime
dur = (Collect -> Collect) -> Deriver ()
Internal.modify_collect forall a b. (a -> b) -> a -> b
$ \Collect
collect ->
    Collect
collect { collect_real_duration :: CallDuration RealTime
Derive.collect_real_duration = CallDuration RealTime
dur }

-- ** transformer

{-# SCC eval_transformers #-}
eval_transformers :: (Derive.Callable (Derive.Transformer d), Derive.Taggable d)
    => Derive.Context d -> [DeriveT.Call] -> Derive.Deriver (Stream.Stream d)
    -> Derive.Deriver (Stream.Stream d)
eval_transformers :: forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> [Call] -> Deriver (Stream d) -> Deriver (Stream d)
eval_transformers Context d
ctx [Call]
calls Deriver (Stream d)
deriver = [Call] -> Deriver (Stream d)
go [Call]
calls
    where
    go :: [Call] -> Deriver (Stream d)
go [] = Deriver (Stream d)
deriver
    go (Expr.Call Symbol
sym [Term Val]
args : [Call]
calls) = do
        [Val]
vals <- 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 Val -> Deriver Val
eval Context d
ctx) [Term Val]
args
        Transformer d
call <- forall d.
Callable (Transformer d) =>
Symbol -> Deriver (Transformer d)
get_transformer Symbol
sym
        forall d.
Context d
-> Transformer d
-> [Val]
-> Deriver (Stream d)
-> Deriver (Stream d)
apply_transformer Context d
ctx Transformer d
call [Val]
vals ([Call] -> Deriver (Stream d)
go [Call]
calls)

-- | Parse and apply a transformer expression.
eval_transform_expr ::
    (Derive.Callable (Derive.Transformer d), Derive.Taggable d)
    => Text -> Text -> Derive.Deriver (Stream.Stream d)
    -> Derive.Deriver (Stream.Stream d)
eval_transform_expr :: forall d.
(Callable (Transformer d), Taggable d) =>
Text -> Text -> Deriver (Stream d) -> Deriver (Stream d)
eval_transform_expr Text
name Text
expr_str Deriver (Stream d)
deriver
    | (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
Char.isSpace Text
expr_str = Deriver (Stream d)
deriver
    | Bool
otherwise = do
        Expr
expr <- case Text -> Either Text Expr
Parse.parse_expr Text
expr_str of
            Left Text
err -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
name forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
            Right Expr
expr -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr
expr
        let ctx :: Context a
ctx = forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
0 ScoreTime
1 Text
name
        forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> [Call] -> Deriver (Stream d) -> Deriver (Stream d)
eval_transformers forall {a}. Context a
ctx (forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
expr) Deriver (Stream d)
deriver

-- | The same as 'eval_transformers', but get them out of a Quoted.
eval_quoted_transformers ::
    (Derive.Callable (Derive.Transformer d), Derive.Taggable d)
    => Derive.Context d -> DeriveT.Quoted -> Derive.Deriver (Stream.Stream d)
    -> Derive.Deriver (Stream.Stream d)
eval_quoted_transformers :: forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> Quoted -> Deriver (Stream d) -> Deriver (Stream d)
eval_quoted_transformers Context d
ctx (DeriveT.Quoted Expr
expr) =
    forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> [Call] -> Deriver (Stream d) -> Deriver (Stream d)
eval_transformers Context d
ctx (forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
expr)

-- | The transformer version of 'apply_generator'.  Like 'eval_transformers',
-- but apply only one, and apply to already evaluated 'DeriveT.Val's.  This
-- is useful when you want to re-apply an already parsed set of vals.
{-# SCC apply_transformer #-}
apply_transformer :: Derive.Context d -> Derive.Transformer d -> [DeriveT.Val]
    -> Derive.Deriver (Stream.Stream d) -> Derive.Deriver (Stream.Stream d)
apply_transformer :: forall d.
Context d
-> Transformer d
-> [Val]
-> Deriver (Stream d)
-> Deriver (Stream d)
apply_transformer Context d
ctx Transformer d
call [Val]
args Deriver (Stream d)
deriver =
    forall a. CallName -> Deriver a -> Deriver a
Internal.with_stack_call (forall func. Call func -> CallName
Derive.call_name Transformer d
call) forall a b. (a -> b) -> a -> b
$
        forall func. Call func -> func
Derive.call_func Transformer d
call PassedArgs d
passed Deriver (Stream d)
deriver
    where
    passed :: PassedArgs d
passed = Derive.PassedArgs
        { passed_vals :: [Val]
passed_vals = [Val]
args
        , passed_call_name :: CallName
passed_call_name = forall func. Call func -> CallName
Derive.call_name Transformer d
call
        , passed_ctx :: Context d
passed_ctx = Context d
ctx
        }

-- | A list version of 'apply_transformer'.
apply_transformers :: Derive.Context d
    -> [(Derive.Transformer d, [DeriveT.Val])]
    -> Derive.Deriver (Stream.Stream d) -> Derive.Deriver (Stream.Stream d)
apply_transformers :: forall d.
Context d
-> [(Transformer d, [Val])]
-> Deriver (Stream d)
-> Deriver (Stream d)
apply_transformers Context d
ctx [(Transformer d, [Val])]
calls Deriver (Stream d)
deriver = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Transformer d, [Val]) -> Deriver (Stream d) -> Deriver (Stream d)
apply Deriver (Stream d)
deriver [(Transformer d, [Val])]
calls
    where apply :: (Transformer d, [Val]) -> Deriver (Stream d) -> Deriver (Stream d)
apply (Transformer d
sym, [Val]
args) = forall d.
Context d
-> Transformer d
-> [Val]
-> Deriver (Stream d)
-> Deriver (Stream d)
apply_transformer Context d
ctx Transformer d
sym [Val]
args

-- ** val call

{-# SCC eval #-}
eval :: Derive.Taggable a => Derive.Context a -> DeriveT.Term
    -> Derive.Deriver DeriveT.Val
eval :: forall a. Taggable a => Context a -> Term Val -> Deriver Val
eval Context a
_ (Expr.Literal Val
val) = forall (m :: * -> *) a. Monad m => a -> m a
return Val
val
eval Context a
ctx (Expr.ValCall (Expr.Call Symbol
sym [Term Val]
terms)) = do
    ValCall
call <- Symbol -> Deriver ValCall
get_val_call Symbol
sym
    Context Tagged -> ValCall -> [Term Val] -> Deriver Val
apply (forall a. Taggable a => Context a -> Context Tagged
Derive.tag_context Context a
ctx) ValCall
call [Term Val]
terms

{-# SCC apply #-}
apply :: Derive.Context Derive.Tagged -> Derive.ValCall
    -> [DeriveT.Term] -> Derive.Deriver DeriveT.Val
apply :: Context Tagged -> ValCall -> [Term Val] -> Deriver Val
apply Context Tagged
ctx ValCall
call [Term Val]
args = do
    [Val]
vals <- 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 Val -> Deriver Val
eval Context Tagged
ctx) [Term Val]
args
    let passed :: PassedArgs Tagged
passed = Derive.PassedArgs
            { passed_vals :: [Val]
passed_vals = [Val]
vals
            , passed_call_name :: CallName
passed_call_name = ValCall -> CallName
Derive.vcall_name ValCall
call
            , passed_ctx :: Context Tagged
passed_ctx = Context Tagged
ctx
            }
    forall a. CallName -> Deriver a -> Deriver a
Internal.with_stack_call (ValCall -> CallName
Derive.vcall_name ValCall
call) forall a b. (a -> b) -> a -> b
$
        ValCall -> PassedArgs Tagged -> Deriver Val
Derive.vcall_call ValCall
call PassedArgs Tagged
passed

-- * lookup call

get_val_call :: Expr.Symbol -> Derive.Deriver Derive.ValCall
get_val_call :: Symbol -> Deriver ValCall
get_val_call Symbol
sym = forall a. Bool -> Symbol -> Text -> Maybe a -> Deriver a
require_call Bool
False Symbol
sym Text
name 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 Derive.ValCall)

get_generator :: forall d. Derive.Callable (Derive.Generator d) =>
    Expr.Symbol -> Derive.Deriver (Derive.Generator d)
get_generator :: forall d. Callable (Generator d) => Symbol -> Deriver (Generator d)
get_generator Symbol
sym = forall a. Bool -> Symbol -> Text -> Maybe a -> Deriver a
require_call Bool
True Symbol
sym Text
name 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 (Derive.Generator d))

get_transformer :: forall d. Derive.Callable (Derive.Transformer d) =>
    Expr.Symbol -> Derive.Deriver (Derive.Transformer d)
get_transformer :: forall d.
Callable (Transformer d) =>
Symbol -> Deriver (Transformer d)
get_transformer Symbol
sym =
    forall a. Bool -> Symbol -> Text -> Maybe a -> Deriver a
require_call Bool
False Symbol
sym Text
name 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 (Derive.Transformer d))

get_track_call :: forall d. Derive.Callable (Derive.TrackCall d) =>
    Expr.Symbol -> Derive.Deriver (Derive.TrackCall d)
get_track_call :: forall d. Callable (TrackCall d) => Symbol -> Deriver (TrackCall d)
get_track_call Symbol
sym =
    forall a. Bool -> Symbol -> Text -> Maybe a -> Deriver a
require_call Bool
False Symbol
sym Text
name 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 (Derive.TrackCall d))

require_call :: Bool -> Expr.Symbol -> Text -> Maybe a -> Derive.Deriver a
require_call :: forall a. Bool -> Symbol -> Text -> Maybe a -> Deriver a
require_call Bool
_ Symbol
_ Text
_ (Just a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
require_call Bool
is_generator Symbol
sym Text
name Maybe a
Nothing = do
    -- If the call wasn't found, it can be seen as a block call whose block
    -- doesn't exist yet.  If it is created later, I have to know that this
    -- block depends on it, otherwise it won't be rederived and hence won't
    -- realize that the bad call is now valid.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_generator forall a b. (a -> b) -> a -> b
$ do
        Maybe BlockId
caller <- Deriver (Maybe BlockId)
Internal.lookup_current_block_id
        Namespace
ns <- forall a. (State -> a) -> Deriver a
Derive.get_ui_state forall a b. (a -> b) -> a -> b
$ Config -> Namespace
UiConfig.config_namespace forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Ui.state_config
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Namespace -> Maybe BlockId -> Symbol -> Maybe BlockId
call_to_block_id Namespace
ns Maybe BlockId
caller Symbol
sym) BlockId -> Deriver ()
Internal.add_block_dep
    forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text -> Symbol -> Text
unknown_symbol Text
name Symbol
sym

unknown_symbol :: Text -> Expr.Symbol -> Text
unknown_symbol :: Text -> Symbol -> Text
unknown_symbol Text
name Symbol
sym = Text
name forall a. Semigroup a => a -> a -> a
<> Text
" not found: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Symbol
sym

-- | Given a Symbol, try to come up with the BlockId of the block it could be
-- a call for.
call_to_block_id :: Id.Namespace -> Maybe BlockId
    -- ^ If the symbol starts with -, this block is prepended to it.
    -> Expr.Symbol -> Maybe BlockId
call_to_block_id :: Namespace -> Maybe BlockId -> Symbol -> Maybe BlockId
call_to_block_id Namespace
ns Maybe BlockId
maybe_caller Symbol
sym
    | Symbol
sym forall a. Eq a => a -> a -> Bool
== Symbol
"" = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Id -> BlockId
Id.BlockId forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Id
Id.read_short Namespace
ns Text
relative
    where
    relative :: Text
relative
        | Just BlockId
caller <- Maybe BlockId
maybe_caller, Symbol -> Bool
is_relative Symbol
sym =
            forall a. Ident a => a -> Text
Id.ident_text BlockId
caller forall a. Semigroup a => a -> a -> a
<> Symbol -> Text
Expr.unsym Symbol
sym
        | Bool
otherwise = Symbol -> Text
Expr.unsym Symbol
sym

-- | Create the symbol to call a given block.
block_id_to_call :: Bool -> BlockId -> BlockId -> Text
block_id_to_call :: Bool -> BlockId -> BlockId -> Text
block_id_to_call Bool
relative BlockId
parent BlockId
child
    | forall a. Ident a => a -> Namespace
Id.ident_namespace BlockId
parent forall a. Eq a => a -> a -> Bool
/= forall a. Ident a => a -> Namespace
Id.ident_namespace BlockId
child =
        Id -> Text
Id.show_id (forall a. Ident a => a -> Id
Id.unpack_id BlockId
child)
    | Bool
relative, Just Text
suffix <- Text -> Text -> Maybe Text
Text.stripPrefix
            (Text
parent_name forall a. Semigroup a => a -> a -> a
<> Text
relative_separator) Text
child_name =
        Text
relative_separator forall a. Semigroup a => a -> a -> a
<> Text
suffix
    | Bool
otherwise = Text
child_name
    where
    child_name :: Text
child_name = forall a. Ident a => a -> Text
Id.ident_name BlockId
child
    parent_name :: Text
parent_name = forall a. Ident a => a -> Text
Id.ident_name BlockId
parent

-- | True if this is a relative block call.
is_relative :: Expr.Symbol -> Bool
is_relative :: Symbol -> Bool
is_relative = (Text
relative_separator `Text.isPrefixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Text
Expr.unsym

-- | Make a block name relative to a parent block.
make_relative :: BlockId -> Text -> Text
make_relative :: BlockId -> Text -> Text
make_relative BlockId
block_id Text
name =
    forall a. Ident a => a -> Text
Id.ident_name BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
relative_separator forall a. Semigroup a => a -> a -> a
<> Text
name

-- | If it's a relative BlockId, return the parent and relative call.
parse_relative_id :: BlockId -> Maybe (BlockId, Id.Id)
parse_relative_id :: BlockId -> Maybe (BlockId, Id)
parse_relative_id BlockId
block_id
    | Text -> Bool
Text.null Text
post = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just
        ( Id -> BlockId
Id.BlockId forall a b. (a -> b) -> a -> b
$ Text -> Id -> Id
Id.set_name Text
pre (forall a. Ident a => a -> Id
Id.unpack_id BlockId
block_id)
        , Namespace -> Text -> Id
Id.id (forall a. Ident a => a -> Namespace
Id.ident_namespace BlockId
block_id) (Serial -> Text -> Text
Text.drop Serial
1 Text
post)
        )
    where (Text
pre, Text
post) = HasCallStack => Text -> Text -> (Text, Text)
Text.breakOn Text
relative_separator forall a b. (a -> b) -> a -> b
$ forall a. Ident a => a -> Text
Id.ident_name BlockId
block_id

relative_separator :: Text
relative_separator :: Text
relative_separator = Text
"-"

-- * util

-- | Evaluate a single note as a generator.  Fake up an event with no prev or
-- next lists.
eval_one :: Derive.CallableExpr d => Bool -> DeriveT.Expr
    -> Derive.Deriver (Stream.Stream d)
eval_one :: forall d. CallableExpr d => Bool -> Expr -> Deriver (Stream d)
eval_one Bool
collect = forall d.
CallableExpr d =>
Bool -> ScoreTime -> ScoreTime -> Expr -> Deriver (Stream d)
eval_one_at Bool
collect ScoreTime
0 ScoreTime
1

eval_one_call :: Derive.CallableExpr d => Bool -> DeriveT.Call
    -> Derive.Deriver (Stream.Stream d)
eval_one_call :: forall d. CallableExpr d => Bool -> Call -> Deriver (Stream d)
eval_one_call Bool
collect = forall d. CallableExpr d => Bool -> Expr -> Deriver (Stream d)
eval_one Bool
collect forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> NonEmpty a
:| [])

eval_one_at :: Derive.CallableExpr d => Bool -> ScoreTime -> ScoreTime
    -> DeriveT.Expr -> Derive.Deriver (Stream.Stream d)
eval_one_at :: forall d.
CallableExpr d =>
Bool -> ScoreTime -> ScoreTime -> Expr -> Deriver (Stream d)
eval_one_at Bool
collect ScoreTime
start ScoreTime
dur Expr
expr = forall d.
CallableExpr d =>
Bool -> Context d -> Expr -> Deriver (Stream d)
eval_expr Bool
collect forall {a}. Context a
ctx Expr
expr
    where
    -- Set the event start and duration instead of using Derive.place since
    -- this way I can have zero duration events.
    ctx :: Context a
ctx = forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
start ScoreTime
dur forall a b. (a -> b) -> a -> b
$ forall a. ShowVal a => a -> Text
ShowVal.show_val Expr
expr

-- | Like 'Derive.EvalTrack.derive_event' but evaluate the event outside of its
-- track context.  This is useful if you want to evaluate things out of order,
-- i.e. evaluate the /next/ pitch.
eval_event :: Derive.CallableExpr d => Event.Event
    -> Derive.Deriver (Either Text (Stream.Stream d))
eval_event :: forall d.
CallableExpr d =>
Event -> Deriver (Either Text (Stream d))
eval_event Event
event = case Text -> Either Text Expr
Parse.parse_expr (Event -> Text
Event.text Event
event) of
    Left Text
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
err
    Right Expr
expr -> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        -- TODO eval it separately to catch any exception?
        forall d.
CallableExpr d =>
Bool -> ScoreTime -> ScoreTime -> Expr -> Deriver (Stream d)
eval_one_at Bool
False (Event -> ScoreTime
Event.start Event
event) (Event -> ScoreTime
Event.duration Event
event) Expr
expr

-- | Evaluate a generator, reusing the passed args but replacing the Symbol.
-- Generators can use this to delegate to other generators.
reapply_generator :: Derive.Callable (Derive.Generator d)
    => Derive.PassedArgs d -> Expr.Symbol -> Derive.Deriver (Stream.Stream d)
reapply_generator :: forall d.
Callable (Generator d) =>
PassedArgs d -> Symbol -> Deriver (Stream d)
reapply_generator PassedArgs d
args Symbol
sym = do
    let ctx :: Context d
ctx = forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args
    Generator d
call <- forall d. Callable (Generator d) => Symbol -> Deriver (Generator d)
get_generator Symbol
sym
    forall d. Context d -> Generator d -> [Val] -> Deriver (Stream d)
apply_generator Context d
ctx Generator d
call (forall val. PassedArgs val -> [Val]
Derive.passed_vals PassedArgs d
args)

-- | Like 'reapply_generator', but the note is given normalized time, 0--1,
-- instead of inheriting the start and duration from the args.  This is
-- essential if you want to shift or stretch the note.
reapply_generator_normalized :: Derive.Callable (Derive.Generator d)
    => Derive.PassedArgs d -> Expr.Symbol -> Derive.Deriver (Stream.Stream d)
reapply_generator_normalized :: forall d.
Callable (Generator d) =>
PassedArgs d -> Symbol -> Deriver (Stream d)
reapply_generator_normalized PassedArgs d
args = forall d.
Callable (Generator d) =>
PassedArgs d -> Symbol -> Deriver (Stream d)
reapply_generator forall a b. (a -> b) -> a -> b
$ PassedArgs d
args
    { passed_ctx :: Context d
Derive.passed_ctx = Context d
ctx
        { ctx_event :: Event
Derive.ctx_event = ScoreTime -> ScoreTime -> Event -> Event
Event.place ScoreTime
0 ScoreTime
1 (forall val. Context val -> Event
Derive.ctx_event Context d
ctx)
        , ctx_event_end :: ScoreTime
Derive.ctx_event_end = ScoreTime
1
        }
    }
    where ctx :: Context d
ctx = forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args

-- | Apply an expr with an explicit Context.  You can use this to reuse the
-- current call's Context, but be careful because it will also inherit the
-- 'Derive.ctx_sub_tracks', which means if inversion hasn't happened yet, which
-- may be what you want or may be surprising.  For instance, it will likely
-- override any pitch you try to set.
reapply :: Derive.CallableExpr d => Derive.Context d -> DeriveT.Expr
    -> Derive.Deriver (Stream.Stream d)
reapply :: forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
reapply = forall d.
CallableExpr d =>
Bool -> Context d -> Expr -> Deriver (Stream d)
eval_expr Bool
True

reapply_call :: Derive.CallableExpr d => Derive.Context d -> Expr.Symbol
    -> [DeriveT.Term] -> Derive.Deriver (Stream.Stream d)
reapply_call :: forall d.
CallableExpr d =>
Context d -> Symbol -> [Term Val] -> Deriver (Stream d)
reapply_call Context d
ctx Symbol
sym [Term Val]
call_args =
    forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
reapply Context d
ctx (forall val. Call val -> Expr val
Expr.generator forall a b. (a -> b) -> a -> b
$ forall val. Symbol -> [Term val] -> Call val
Expr.Call Symbol
sym [Term Val]
call_args)

-- | A version of 'eval' specialized to evaluate pitch calls.  It's unknown if
-- this pitch has been transposed or not.
eval_pitch :: ScoreTime -> DeriveT.PitchCall
    -> Derive.Deriver (PSignal.RawPitch a)
eval_pitch :: forall a. ScoreTime -> Call -> Deriver (RawPitch a)
eval_pitch ScoreTime
pos Call
call = do
    Pitch
pitch <- forall a. Typecheck a => Text -> ScoreTime -> Val -> Deriver a
Typecheck.typecheck (Text
"eval pitch " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Call
call) ScoreTime
pos
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Taggable a => Context a -> Term Val -> Deriver Val
eval Context Pitch
ctx (forall val. Call val -> Term val
Expr.ValCall Call
call)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. RawPitch a -> RawPitch b
PSignal.coerce (Pitch
pitch :: PSignal.Pitch)
    where
    ctx :: Derive.Context Derive.Pitch
    ctx :: Context Pitch
ctx = forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
pos ScoreTime
0 Text
"<eval_pitch>"

-- | Get a Pitch from in a given scale.  Like 'eval_pitch', it's unknown if
-- this pitch has been transposed or not.
eval_note :: Derive.Scale -> Pitch.Note -> Derive.Deriver (PSignal.RawPitch a)
eval_note :: forall a. Scale -> Note -> Deriver (RawPitch a)
eval_note Scale
scale Note
note = case Scale -> Note -> Maybe ValCall
Derive.scale_note_to_call Scale
scale Note
note of
    Maybe ValCall
Nothing -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Scale
scale forall a. Semigroup a => a -> a -> a
<> Text
" has no note " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Note
note
    Just ValCall
vcall -> forall a. ScoreTime -> ValCall -> Deriver (RawPitch a)
apply_pitch ScoreTime
0 ValCall
vcall

-- | This is like 'eval_pitch' when you already know the call, presumably
-- because you asked 'Derive.scale_note_to_call'.
apply_pitch :: ScoreTime -> Derive.ValCall
    -> Derive.Deriver (PSignal.RawPitch a)
apply_pitch :: forall a. ScoreTime -> ValCall -> Deriver (RawPitch a)
apply_pitch ScoreTime
pos ValCall
call = do
    Pitch
pitch <- forall a. Typecheck a => Text -> ScoreTime -> Val -> Deriver a
Typecheck.typecheck Text
msg ScoreTime
pos forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context Tagged -> ValCall -> [Term Val] -> Deriver Val
apply forall {a}. Context a
ctx ValCall
call []
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. RawPitch a -> RawPitch b
PSignal.coerce (Pitch
pitch :: PSignal.Pitch)
    where
    msg :: Text
msg = Text
"apply pitch: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (ValCall -> CallName
Derive.vcall_name ValCall
call)
    ctx :: Context a
ctx = forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
pos ScoreTime
0 Text
"<apply_pitch>"

-- | Evaluate a single expression, catching an exception if it throws.
eval_expr :: Derive.CallableExpr d => Bool -- ^ See 'Derive.catch'.  This
    -- should be True for evals that generate notes for eventual output.
    -> Derive.Context d -> DeriveT.Expr -> Derive.Deriver (Stream.Stream d)
eval_expr :: forall d.
CallableExpr d =>
Bool -> Context d -> Expr -> Deriver (Stream d)
eval_expr Bool
collect Context d
ctx Expr
expr =
    forall a. a -> Maybe a -> a
fromMaybe forall a. Stream a
Stream.empty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Bool -> Deriver a -> Deriver (Maybe a)
Derive.catch Bool
collect (forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
eval_toplevel Context d
ctx Expr
expr)