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

{- | This has the higher level parts of the deriver library.  That is,
    functions where are considered basic but can be defined outside of
    "Derive.Deriver.Monad".
-}
module Derive.Deriver.Lib (
    Result(..)
    , derive
    , extract_result
    , with_default_imported
    -- * errors
    , require, require_right
    , catch

    -- * state access
    , get_stack
    , real_function, score_function
    -- ** import
    , with_imported, with_imported_symbols
    , with_scopes
    -- ** scale
    , get_scale, lookup_scale

    -- ** environment
    , lookup_val, is_val_set, get_val
    , with_val, with_vals
    , with_environ
    , with_val_raw
    , delete_val
    , with_merged_numeric_val
    , modify_val
    , with_scale, with_instrument
    , with_instrument_alias, with_instrument_aliases
    , instrument_exists
    , get_instrument, lookup_instrument

    -- ** control
    , lookup_control
    , is_control_set
    , signal_function
    , lookup_control_signal
    , get_controls
    , get_control_functions
    , control_at, untyped_control_at, controls_at
    , state_controls_at

    -- *** control signal
    , with_control, with_constant_control, with_controls
    , remove_controls
    , with_control_function
    , with_control_maps
    , with_merged_control, with_merged_controls
    , resolve_merge
    , get_control_merge
    , get_default_merger

    -- *** ControlMod
    , modify_control
    , eval_control_mods
    , with_control_mods

    -- ** pitch
    , pitch_at, named_pitch_at
    , resolve_pitch
    , nn_at
    , get_pitch, get_named_pitch
    , named_nn_at
    , logged_pitch_nn

    -- *** with signal
    , with_pitch, with_named_pitch, with_constant_pitch
    , remove_pitch

    -- * run monad
    , run_logs

    -- * Mode
    , get_mode
    , is_lilypond_mode
    , lookup_lilypond_config
    , get_score_duration, get_real_duration

    -- * postproc
    , with_event
    , with_event_stack
    , shift_controls

    -- * call
    , val_call
    , set_module
) where
import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set

import qualified Util.Doc as Doc
import qualified Util.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Seq as Seq

import qualified Derive.Call.Module as Module
import qualified Derive.Call.Tags as Tags
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream
import qualified Derive.Symbols as Symbols
import qualified Derive.TrackWarp as TrackWarp
import qualified Derive.Typecheck as Typecheck
import qualified Derive.Warp as Warp

import qualified Perform.Lilypond.Types as Lilypond.Types
import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import qualified Ui.Event as Event
import qualified Ui.Ruler as Ruler
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui

import           Derive.Deriver.Monad
import           Global
import           Types


-- * derive

-- This should probably be in Internal, but can't due to a circular dependency
-- with 'real'.  TODO except not any more.  But Internal is lower level, so
-- maybe it should have less stuff in it anyway?

-- | Package up the results of a derivation.
data Result = Result {
    Result -> Stream Event
r_events :: !(Stream.Stream Score.Event)
    , Result -> Cache
r_cache :: !Cache
    , Result -> [TrackWarp]
r_track_warps :: ![TrackWarp.TrackWarp]
    , Result -> TrackSignals
r_track_signals :: !Track.TrackSignals
    , Result -> TrackDynamic
r_track_dynamic :: !TrackDynamic
    , Result -> [Integrated]
r_integrated :: ![Integrated]

    -- | The relevant parts of the final state should be extracted into the
    -- above fields, but returning the whole state can be useful for testing.
    , Result -> State
r_state :: !State
    }

-- | Kick off a derivation.
derive :: Constant -> Dynamic -> Deriver a -> RunResult a
derive :: forall a. Constant -> Dynamic -> Deriver a -> RunResult a
derive Constant
constant Dynamic
dynamic = State -> Deriver State Error a -> RunResult State Error a
forall st err a. st -> Deriver st err a -> RunResult st err a
run (Constant -> Dynamic -> State
initial_state Constant
constant Dynamic
dynamic)
    (Deriver State Error a -> RunResult State Error a)
-> (Deriver State Error a -> Deriver State Error a)
-> Deriver State Error a
-> RunResult State Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> Deriver State Error a -> Deriver State Error a
forall d. Environ -> Deriver d -> Deriver d
with_initial_scope (Dynamic -> Environ
state_environ Dynamic
dynamic)
    (Deriver State Error a -> Deriver State Error a)
-> (Deriver State Error a -> Deriver State Error a)
-> Deriver State Error a
-> Deriver State Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deriver State Error a -> Deriver State Error a
forall a. Deriver a -> Deriver a
with_default_imported

extract_result :: RunResult (Stream.Stream Score.Event) -> Result
extract_result :: RunResult (Stream Event) -> Result
extract_result (Either Error (Stream Event)
result, State
state, [Msg]
logs) = Result
    { r_events :: Stream Event
r_events = Either Error (Stream Event) -> [Msg] -> Stream Event
forall a. Either Error (Stream a) -> [Msg] -> Stream a
merge_logs Either Error (Stream Event)
result ([Msg]
more_logs [Msg] -> [Msg] -> [Msg]
forall a. [a] -> [a] -> [a]
++ [Msg]
logs)
    , r_cache :: Cache
r_cache = Collect -> Cache
collect_cache Collect
collect Cache -> Cache -> Cache
forall a. Semigroup a => a -> a -> a
<> Constant -> Cache
state_cache (State -> Constant
state_constant State
state)
    , r_track_warps :: [TrackWarp]
r_track_warps =
        [(BlockId, [Tree TrackId])] -> WarpMap -> [TrackWarp]
TrackWarp.collect_track_warps [(BlockId, [Tree TrackId])]
blocks (Collect -> WarpMap
collect_warp_map Collect
collect)
    , r_track_signals :: TrackSignals
r_track_signals = Collect -> TrackSignals
collect_track_signals Collect
collect
    , r_track_dynamic :: TrackDynamic
r_track_dynamic = Collect -> TrackDynamic
extract_track_dynamic Collect
collect
    , r_integrated :: [Integrated]
r_integrated = Collect -> [Integrated]
collect_integrated Collect
collect
    , r_state :: State
r_state = State
state
    }
    where
    ([Msg]
more_logs, [(BlockId, [Tree TrackId])]
blocks) =
        case State
-> StateId [(BlockId, [Tree TrackId])]
-> Either Error ([(BlockId, [Tree TrackId])], State, UiDamage)
forall a. State -> StateId a -> Either Error (a, State, UiDamage)
Ui.run_id State
ui_state StateId [(BlockId, [Tree TrackId])]
forall (m :: * -> *). M m => m [(BlockId, [Tree TrackId])]
TrackWarp.get_track_trees of
            Left Error
err -> ([Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn Maybe Stack
forall a. Maybe a
Nothing Text
msg], [])
                where msg :: Text
msg = Text
"error collecting TrackWarps: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Error -> Text
forall a. Pretty a => a -> Text
pretty Error
err
            Right ([(BlockId, [Tree TrackId])]
blocks, State
_, UiDamage
_) -> ([], [(BlockId, [Tree TrackId])]
blocks)
    ui_state :: State
ui_state = Constant -> State
state_ui (Constant -> State) -> Constant -> State
forall a b. (a -> b) -> a -> b
$ State -> Constant
state_constant State
state
    collect :: Collect
collect = State -> Collect
state_collect State
state

-- | Extract the merged TrackDynamic from the Collect.
--
-- 'EnvKey.scale' comes from the inverted Collect because the scale track is
-- often inverted below the note track.  However, the others come from the
-- non-inverted Collect because if the note track sets an instrument, I want to
-- use its instrument, instead of any instrument on individual events.  E.g.
-- @>kendang-pasang@ has events that are @>kendang-wadon@ or @>kendang-lanang@.
--
-- See 'Collect' and 'TrackDynamic' for why.
extract_track_dynamic :: Collect -> TrackDynamic
extract_track_dynamic :: Collect -> TrackDynamic
extract_track_dynamic Collect
collect =
    Dynamic -> Dynamic
strip_dynamic (Dynamic -> Dynamic)
-> (Paired Dynamic Dynamic -> Dynamic)
-> Paired Dynamic Dynamic
-> Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Paired Dynamic Dynamic -> Dynamic
extract (Paired Dynamic Dynamic -> Dynamic)
-> Map (BlockId, TrackId) (Paired Dynamic Dynamic) -> TrackDynamic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackDynamic
-> TrackDynamic -> Map (BlockId, TrackId) (Paired Dynamic Dynamic)
forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> Map k (Paired v1 v2)
Maps.paired
        (Collect -> TrackDynamic
collect_track_dynamic Collect
collect) (Collect -> TrackDynamic
collect_track_dynamic_inverted Collect
collect)
    where
    extract :: Paired Dynamic Dynamic -> Dynamic
extract = \case
        Seq.First Dynamic
dyn -> Dynamic
dyn
        Seq.Second Dynamic
dyn -> Dynamic
dyn
        Seq.Both Dynamic
normal Dynamic
inverted -> Dynamic -> Dynamic -> Dynamic
merge Dynamic
normal Dynamic
inverted
    merge :: Dynamic -> Dynamic -> Dynamic
merge Dynamic
normal Dynamic
inverted = Dynamic
normal
        { state_environ :: Environ
state_environ = Environ -> Environ
keep (Dynamic -> Environ
state_environ Dynamic
inverted) Environ -> Environ -> Environ
forall a. Semigroup a => a -> a -> a
<> Dynamic -> Environ
state_environ Dynamic
normal
        }
    keep :: Environ -> Environ
keep Environ
env = Environ -> (Val -> Environ) -> Maybe Val -> Environ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Environ
forall a. Monoid a => a
mempty ([(Text, Val)] -> Environ
Env.from_list ([(Text, Val)] -> Environ)
-> (Val -> [(Text, Val)]) -> Val -> Environ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Val) -> [(Text, Val)] -> [(Text, Val)]
forall a. a -> [a] -> [a]
:[]) ((Text, Val) -> [(Text, Val)])
-> (Val -> (Text, Val)) -> Val -> [(Text, Val)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Text
EnvKey.scale) (Maybe Val -> Environ) -> Maybe Val -> Environ
forall a b. (a -> b) -> a -> b
$
        Text -> Environ -> Maybe Val
Env.lookup Text
EnvKey.scale Environ
env

-- | Given an environ, bring instrument and scale calls into scope.
with_initial_scope :: Env.Environ -> Deriver d -> Deriver d
with_initial_scope :: forall d. Environ -> Deriver d -> Deriver d
with_initial_scope Environ
env Deriver d
deriver = Deriver d -> Deriver d
forall a. Deriver a -> Deriver a
set_inst (Deriver d -> Deriver d
forall a. Deriver a -> Deriver a
set_scale Deriver d
deriver)
    where
    set_inst :: Deriver d -> Deriver d
set_inst = case Text -> Environ -> Either LookupError Instrument
forall a. Typecheck a => Text -> Environ -> Either LookupError a
Env.get_val Text
EnvKey.instrument Environ
env of
        Right Instrument
inst -> Instrument -> Deriver d -> Deriver d
forall d. Instrument -> Deriver d -> Deriver d
with_instrument Instrument
inst
        Either LookupError Instrument
_ -> Deriver d -> Deriver d
forall a. a -> a
id
    set_scale :: Deriver b -> Deriver b
set_scale = case Text -> Environ -> Either LookupError Str
forall a. Typecheck a => Text -> Environ -> Either LookupError a
Env.get_val Text
EnvKey.scale Environ
env of
        Right Str
str -> \Deriver b
deriver -> do
            Scale
scale <- ScaleId -> Deriver Scale
get_scale (Str -> ScaleId
Expr.str_to_scale_id Str
str)
            Scale -> Deriver b -> Deriver b
forall d. Scale -> Deriver d -> Deriver d
with_scale Scale
scale Deriver b
deriver
        Either LookupError Str
_ -> Deriver b -> Deriver b
forall a. a -> a
id

with_default_imported :: Deriver a -> Deriver a
with_default_imported :: forall a. Deriver a -> Deriver a
with_default_imported Deriver a
deriver =
    (Module -> Deriver a -> Deriver a)
-> Deriver a -> [Module] -> Deriver a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Module -> Deriver a -> Deriver a
forall a. Bool -> Module -> Deriver a -> Deriver a
with_imported Bool
True) Deriver a
deriver
        [Module
Module.internal, Module
Module.prelude, Module
Module.local]
    -- Calls from Module.local should shadow the others.


-- * errors

-- | If the deriver throws, log the error and return Nothing.
catch :: Bool -- ^ If True, incorporate the evaluated 'state_collect'.
    -- This is False for eval which is disconnected from track evaluation, and
    -- shouldn't be accumulating things like 'ControlMod's.
    -> Deriver a -> Deriver (Maybe a)
catch :: forall a. Bool -> Deriver a -> Deriver (Maybe a)
catch Bool
collect Deriver a
deriver = do
    State
state <- Deriver State Error State
forall st err. Deriver st err st
get
    -- It's critical to clear the collect, because if I merge it again later
    -- I can't go duplicating the whole thing.
    let (Either Error a
result, State
state2, [Msg]
logs) = State -> Deriver a -> (Either Error a, State, [Msg])
forall st err a. st -> Deriver st err a -> RunResult st err a
run (State
state { state_collect :: Collect
state_collect = Collect
forall a. Monoid a => a
mempty }) Deriver a
deriver
    (Msg -> Deriver State Error ()) -> [Msg] -> Deriver State Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Msg -> Deriver State Error ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    case Either Error a
result of
        Left Error
err -> do
            Msg -> Deriver State Error ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write (Msg -> Deriver State Error ()) -> Msg -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Error -> Msg
error_to_warn Error
err
            Maybe a -> Deriver (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Right a
val -> do
            Bool -> Deriver State Error () -> Deriver State Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
collect (Deriver State Error () -> Deriver State Error ())
-> Deriver State Error () -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Collect -> Deriver State Error ()
Internal.merge_collect (State -> Collect
state_collect State
state2)
            Threaded -> Deriver State Error ()
Internal.set_threaded (State -> Threaded
state_threaded State
state2)
            Maybe a -> Deriver (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Deriver (Maybe a)) -> Maybe a -> Deriver (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
val


-- * state access

get_stack :: Deriver Stack.Stack
get_stack :: Deriver Stack
get_stack = (State -> Stack) -> Deriver Stack
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Stack
state_stack (Dynamic -> Stack) -> (State -> Dynamic) -> State -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)

real_function :: Deriver (ScoreTime -> RealTime)
real_function :: Deriver (ScoreTime -> RealTime)
real_function = Warp -> ScoreTime -> RealTime
Warp.warp (Warp -> ScoreTime -> RealTime)
-> Deriver State Error Warp -> Deriver (ScoreTime -> RealTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dynamic -> Warp) -> Deriver State Error Warp
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Warp
state_warp

score_function :: Deriver (RealTime -> ScoreTime)
score_function :: Deriver (RealTime -> ScoreTime)
score_function = Warp -> RealTime -> ScoreTime
Warp.unwarp (Warp -> RealTime -> ScoreTime)
-> Deriver State Error Warp -> Deriver (RealTime -> ScoreTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dynamic -> Warp) -> Deriver State Error Warp
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Warp
state_warp

-- ** import

-- | Merge calls from the given module into scope.
with_imported :: Bool -> Module.Module -> Deriver a -> Deriver a
with_imported :: forall a. Bool -> Module -> Deriver a -> Deriver a
with_imported Bool
empty_ok Module
module_ Deriver a
deriver = do
    Builtins
builtins <- (Constant -> Builtins) -> Deriver Builtins
forall a. (Constant -> a) -> Deriver a
Internal.get_constant Constant -> Builtins
state_builtins
    Scopes
scopes <- case Module -> Builtins -> Scopes
extract_module Module
module_ Builtins
builtins of
        Scopes Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
gen Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
trans Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
track ScopePriority ValCall
val
            | Bool -> Bool
not Bool
empty_ok Bool -> Bool -> Bool
&& Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
-> Bool
forall {call} {call} {call}.
Scope
  (ScopePriority call) (ScopePriority call) (ScopePriority call)
-> Bool
scope_empty Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
gen Bool -> Bool -> Bool
&& Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
-> Bool
forall {call} {call} {call}.
Scope
  (ScopePriority call) (ScopePriority call) (ScopePriority call)
-> Bool
scope_empty Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
trans
                    Bool -> Bool -> Bool
&& Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
-> Bool
forall {call} {call} {call}.
Scope
  (ScopePriority call) (ScopePriority call) (ScopePriority call)
-> Bool
scope_empty Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
track Bool -> Bool -> Bool
&& ScopePriority ValCall -> Bool
forall {call}. ScopePriority call -> Bool
empty ScopePriority ValCall
val ->
                Text -> Deriver State Error Scopes
forall a. Stack => Text -> Deriver a
throw (Text -> Deriver State Error Scopes)
-> Text -> Deriver State Error Scopes
forall a b. (a -> b) -> a -> b
$ Text
"no calls in the imported module: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Module -> Text
forall a. Pretty a => a -> Text
pretty Module
module_
        Scopes
extracted -> Scopes -> Deriver State Error Scopes
forall (m :: * -> *) a. Monad m => a -> m a
return Scopes
extracted
    (Scopes -> Scopes) -> Deriver a -> Deriver a
forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
with_scopes (Scopes
scopes<>) Deriver a
deriver
    where
    scope_empty :: Scope
  (ScopePriority call) (ScopePriority call) (ScopePriority call)
-> Bool
scope_empty (Scope ScopePriority call
a ScopePriority call
b ScopePriority call
c) = ScopePriority call -> Bool
forall {call}. ScopePriority call -> Bool
empty ScopePriority call
a Bool -> Bool -> Bool
&& ScopePriority call -> Bool
forall {call}. ScopePriority call -> Bool
empty ScopePriority call
b Bool -> Bool -> Bool
&& ScopePriority call -> Bool
forall {call}. ScopePriority call -> Bool
empty ScopePriority call
c
    empty :: ScopePriority call -> Bool
empty (ScopePriority Map CallPriority (CallMap call)
m) = Map CallPriority (CallMap call) -> Bool
forall k a. Map k a -> Bool
Map.null Map CallPriority (CallMap call)
m

-- | Import only the given symbols from the module.
with_imported_symbols :: Module.Module -> Set Expr.Symbol -> Deriver a
    -> Deriver a
with_imported_symbols :: forall a. Module -> Set Symbol -> Deriver a -> Deriver a
with_imported_symbols Module
module_ Set Symbol
syms Deriver a
deriver = do
    Scopes
scopes <- (Symbol -> Bool) -> Scopes -> Scopes
extract_symbols (Symbol -> Set Symbol -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Symbol
syms) (Scopes -> Scopes) -> (Builtins -> Scopes) -> Builtins -> Scopes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Builtins -> Scopes
extract_module Module
module_ (Builtins -> Scopes)
-> Deriver Builtins -> Deriver State Error Scopes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Constant -> Builtins) -> Deriver Builtins
forall a. (Constant -> a) -> Deriver a
Internal.get_constant Constant -> Builtins
state_builtins
    let missing :: Set Symbol
missing = Set Symbol
syms Set Symbol -> Set Symbol -> Set Symbol
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` [Symbol] -> Set Symbol
forall a. Ord a => [a] -> Set a
Set.fromList (Scopes -> [Symbol]
scope_symbols Scopes
scopes)
    Bool -> Deriver State Error () -> Deriver State Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set Symbol -> Bool
forall a. Set a -> Bool
Set.null Set Symbol
missing) (Deriver State Error () -> Deriver State Error ())
-> Deriver State Error () -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$
        Text -> Deriver State Error ()
forall a. Stack => Text -> Deriver a
throw (Text -> Deriver State Error ()) -> Text -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Text
"symbols not in module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Module -> Text
forall a. Pretty a => a -> Text
pretty Module
module_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Symbol] -> Text
forall a. Pretty a => a -> Text
pretty (Set Symbol -> [Symbol]
forall a. Set a -> [a]
Set.toList Set Symbol
missing)
    (Scopes -> Scopes) -> Deriver a -> Deriver a
forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
with_scopes (Scopes
scopes<>) Deriver a
deriver

-- | Run the derivation with a modified scope.
with_scopes :: (Scopes -> Scopes) -> Deriver a -> Deriver a
with_scopes :: forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
with_scopes Scopes -> Scopes
modify = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state ->
    Dynamic
state { state_scopes :: Scopes
state_scopes = Scopes -> Scopes
modify (Dynamic -> Scopes
state_scopes Dynamic
state) }

-- | Filter out any calls that aren't in the given module.
extract_module :: Module.Module -> Builtins -> Scopes
extract_module :: Module -> Builtins -> Scopes
extract_module Module
module_ (Scopes MkScopeCallMaps
  (Generator Event) (Generator Control) (Generator Pitch)
gen MkScopeCallMaps
  (Transformer Event) (Transformer Control) (Transformer Pitch)
trans MkScopeCallMaps
  (TrackCall Event) (TrackCall Control) (TrackCall Pitch)
track ModuleMap ValCall
val) = Scopes
    { scopes_generator :: Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
scopes_generator = MkScopeCallMaps
  (Generator Event) (Generator Control) (Generator Pitch)
-> Scope
     (ScopePriority (Generator Event))
     (ScopePriority (Generator Control))
     (ScopePriority (Generator Pitch))
forall {a} {a} {a}.
Scope
  (Map Module (CallMap a))
  (Map Module (CallMap a))
  (Map Module (CallMap a))
-> Scope (ScopePriority a) (ScopePriority a) (ScopePriority a)
extract_scope MkScopeCallMaps
  (Generator Event) (Generator Control) (Generator Pitch)
gen
    , scopes_transformer :: Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
scopes_transformer = MkScopeCallMaps
  (Transformer Event) (Transformer Control) (Transformer Pitch)
-> Scope
     (ScopePriority (Transformer Event))
     (ScopePriority (Transformer Control))
     (ScopePriority (Transformer Pitch))
forall {a} {a} {a}.
Scope
  (Map Module (CallMap a))
  (Map Module (CallMap a))
  (Map Module (CallMap a))
-> Scope (ScopePriority a) (ScopePriority a) (ScopePriority a)
extract_scope MkScopeCallMaps
  (Transformer Event) (Transformer Control) (Transformer Pitch)
trans
    , scopes_track :: Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
scopes_track = MkScopeCallMaps
  (TrackCall Event) (TrackCall Control) (TrackCall Pitch)
-> Scope
     (ScopePriority (TrackCall Event))
     (ScopePriority (TrackCall Control))
     (ScopePriority (TrackCall Pitch))
forall {a} {a} {a}.
Scope
  (Map Module (CallMap a))
  (Map Module (CallMap a))
  (Map Module (CallMap a))
-> Scope (ScopePriority a) (ScopePriority a) (ScopePriority a)
extract_scope MkScopeCallMaps
  (TrackCall Event) (TrackCall Control) (TrackCall Pitch)
track
    , scopes_val :: ScopePriority ValCall
scopes_val = ModuleMap ValCall -> ScopePriority ValCall
forall {a}. Map Module (CallMap a) -> ScopePriority a
extract ModuleMap ValCall
val
    }
    where
    extract_scope :: Scope
  (Map Module (CallMap a))
  (Map Module (CallMap a))
  (Map Module (CallMap a))
-> Scope (ScopePriority a) (ScopePriority a) (ScopePriority a)
extract_scope (Scope Map Module (CallMap a)
note Map Module (CallMap a)
control Map Module (CallMap a)
pitch) = Scope
        { scope_note :: ScopePriority a
scope_note = Map Module (CallMap a) -> ScopePriority a
forall {a}. Map Module (CallMap a) -> ScopePriority a
extract Map Module (CallMap a)
note
        , scope_control :: ScopePriority a
scope_control = Map Module (CallMap a) -> ScopePriority a
forall {a}. Map Module (CallMap a) -> ScopePriority a
extract Map Module (CallMap a)
control
        , scope_pitch :: ScopePriority a
scope_pitch = Map Module (CallMap a) -> ScopePriority a
forall {a}. Map Module (CallMap a) -> ScopePriority a
extract Map Module (CallMap a)
pitch
        }
    extract :: Map Module (CallMap a) -> ScopePriority a
extract = CallMap a -> ScopePriority a
forall a. CallMap a -> ScopePriority a
make (CallMap a -> ScopePriority a)
-> (Map Module (CallMap a) -> CallMap a)
-> Map Module (CallMap a)
-> ScopePriority a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallMap a -> Module -> Map Module (CallMap a) -> CallMap a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault CallMap a
forall a. Monoid a => a
mempty Module
module_
    make :: CallMap a -> ScopePriority a
    make :: forall a. CallMap a -> ScopePriority a
make cmap :: CallMap a
cmap@(CallMap Map Symbol a
calls [PatternCall a]
patterns)
        | Map Symbol a -> Bool
forall k a. Map k a -> Bool
Map.null Map Symbol a
calls Bool -> Bool -> Bool
&& [PatternCall a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatternCall a]
patterns = [(CallPriority, CallMap a)] -> ScopePriority a
forall call. [(CallPriority, CallMap call)] -> ScopePriority call
scope_priority []
        | [PatternCall a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatternCall a]
prio_block = [(CallPriority, CallMap a)] -> ScopePriority a
forall call. [(CallPriority, CallMap call)] -> ScopePriority call
scope_priority [(CallPriority
PrioBuiltin, CallMap a
cmap)]
        | Bool
otherwise = [(CallPriority, CallMap a)] -> ScopePriority a
forall call. [(CallPriority, CallMap call)] -> ScopePriority call
scope_priority
            [ (CallPriority
PrioBuiltin, CallMap a
cmap { call_patterns :: [PatternCall a]
call_patterns = [PatternCall a]
normal })
            , (CallPriority
PrioBlock, CallMap a
forall a. Monoid a => a
mempty { call_patterns :: [PatternCall a]
call_patterns = [PatternCall a]
prio_block })
            ]
        where
        ([PatternCall a]
prio_block, [PatternCall a]
normal) =
            (PatternCall a -> Bool)
-> [PatternCall a] -> ([PatternCall a], [PatternCall a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition PatternCall a -> Bool
forall {call}. PatternCall call -> Bool
has_prio_block (CallMap a -> [PatternCall a]
forall call. CallMap call -> [PatternCall call]
call_patterns CallMap a
cmap)
    has_prio_block :: PatternCall call -> Bool
has_prio_block PatternCall call
pattern =
        CallDoc -> Tags
cdoc_tags (PatternCall call -> CallDoc
forall call. PatternCall call -> CallDoc
pat_call_doc PatternCall call
pattern) Tags -> Tags -> Bool
`Tags.contains` Tags
Tags.prio_block

-- | Filter out calls that don't match the predicate.  LookupCalls are also
-- filtered out.  This might be confusing since you might not even know a
-- call comes from a LookupPattern, but then you can't import it by name.
extract_symbols :: (Expr.Symbol -> Bool) -> Scopes -> Scopes
extract_symbols :: (Symbol -> Bool) -> Scopes -> Scopes
extract_symbols Symbol -> Bool
wanted (Scopes Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
gen Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
trans Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
track ScopePriority ValCall
val) = Scopes
    { scopes_generator :: Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
scopes_generator = Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
-> Scope
     (ScopePriority (Generator Event))
     (ScopePriority (Generator Control))
     (ScopePriority (Generator Pitch))
forall {call} {call} {call}.
Scope
  (ScopePriority call) (ScopePriority call) (ScopePriority call)
-> Scope
     (ScopePriority call) (ScopePriority call) (ScopePriority call)
extract_scope Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
gen
    , scopes_transformer :: Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
scopes_transformer = Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
-> Scope
     (ScopePriority (Transformer Event))
     (ScopePriority (Transformer Control))
     (ScopePriority (Transformer Pitch))
forall {call} {call} {call}.
Scope
  (ScopePriority call) (ScopePriority call) (ScopePriority call)
-> Scope
     (ScopePriority call) (ScopePriority call) (ScopePriority call)
extract_scope Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
trans
    , scopes_track :: Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
scopes_track = Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
-> Scope
     (ScopePriority (TrackCall Event))
     (ScopePriority (TrackCall Control))
     (ScopePriority (TrackCall Pitch))
forall {call} {call} {call}.
Scope
  (ScopePriority call) (ScopePriority call) (ScopePriority call)
-> Scope
     (ScopePriority call) (ScopePriority call) (ScopePriority call)
extract_scope Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
track
    , scopes_val :: ScopePriority ValCall
scopes_val = ScopePriority ValCall -> ScopePriority ValCall
forall {call}. ScopePriority call -> ScopePriority call
extract ScopePriority ValCall
val
    }
    where
    extract_scope :: Scope
  (ScopePriority call) (ScopePriority call) (ScopePriority call)
-> Scope
     (ScopePriority call) (ScopePriority call) (ScopePriority call)
extract_scope (Scope ScopePriority call
note ScopePriority call
control ScopePriority call
pitch) = Scope
        { scope_note :: ScopePriority call
scope_note = ScopePriority call -> ScopePriority call
forall {call}. ScopePriority call -> ScopePriority call
extract ScopePriority call
note
        , scope_control :: ScopePriority call
scope_control = ScopePriority call -> ScopePriority call
forall {call}. ScopePriority call -> ScopePriority call
extract ScopePriority call
control
        , scope_pitch :: ScopePriority call
scope_pitch = ScopePriority call -> ScopePriority call
forall {call}. ScopePriority call -> ScopePriority call
extract ScopePriority call
pitch
        }
    extract :: ScopePriority call -> ScopePriority call
extract = (CallMap call -> CallMap call)
-> ScopePriority call -> ScopePriority call
forall {call} {call}.
(CallMap call -> CallMap call)
-> ScopePriority call -> ScopePriority call
map_cmap ((CallMap call -> CallMap call)
 -> ScopePriority call -> ScopePriority call)
-> (CallMap call -> CallMap call)
-> ScopePriority call
-> ScopePriority call
forall a b. (a -> b) -> a -> b
$ \CallMap call
cmap -> CallMap call
forall a. Monoid a => a
mempty
        { call_map :: Map Symbol call
call_map = (Symbol -> Bool) -> Map Symbol call -> Map Symbol call
forall k a. (k -> Bool) -> Map k a -> Map k a
Maps.filterKey Symbol -> Bool
wanted (CallMap call -> Map Symbol call
forall call. CallMap call -> Map Symbol call
call_map CallMap call
cmap) }
    map_cmap :: (CallMap call -> CallMap call)
-> ScopePriority call -> ScopePriority call
map_cmap CallMap call -> CallMap call
f (ScopePriority Map CallPriority (CallMap call)
m) = Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority (Map CallPriority (CallMap call) -> ScopePriority call)
-> Map CallPriority (CallMap call) -> ScopePriority call
forall a b. (a -> b) -> a -> b
$ CallMap call -> CallMap call
f (CallMap call -> CallMap call)
-> Map CallPriority (CallMap call)
-> Map CallPriority (CallMap call)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map CallPriority (CallMap call)
m

scope_symbols :: Scopes -> [Expr.Symbol]
scope_symbols :: Scopes -> [Symbol]
scope_symbols (Scopes Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
gen Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
trans Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
track ScopePriority ValCall
val) = [[Symbol]] -> [Symbol]
forall a. Monoid a => [a] -> a
mconcat
    [Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
-> [Symbol]
forall {a} {a} {a}.
Scope (ScopePriority a) (ScopePriority a) (ScopePriority a)
-> [Symbol]
extract_scope Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator Pitch))
gen, Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
-> [Symbol]
forall {a} {a} {a}.
Scope (ScopePriority a) (ScopePriority a) (ScopePriority a)
-> [Symbol]
extract_scope Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer Pitch))
trans, Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
-> [Symbol]
forall {a} {a} {a}.
Scope (ScopePriority a) (ScopePriority a) (ScopePriority a)
-> [Symbol]
extract_scope Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall Pitch))
track, ScopePriority ValCall -> [Symbol]
forall {a}. ScopePriority a -> [Symbol]
extract ScopePriority ValCall
val]
    where
    extract_scope :: Scope (ScopePriority a) (ScopePriority a) (ScopePriority a)
-> [Symbol]
extract_scope (Scope ScopePriority a
note ScopePriority a
control ScopePriority a
pitch) =
        ScopePriority a -> [Symbol]
forall {a}. ScopePriority a -> [Symbol]
extract ScopePriority a
note [Symbol] -> [Symbol] -> [Symbol]
forall a. Semigroup a => a -> a -> a
<> ScopePriority a -> [Symbol]
forall {a}. ScopePriority a -> [Symbol]
extract ScopePriority a
control [Symbol] -> [Symbol] -> [Symbol]
forall a. Semigroup a => a -> a -> a
<> ScopePriority a -> [Symbol]
forall {a}. ScopePriority a -> [Symbol]
extract ScopePriority a
pitch
    extract :: ScopePriority a -> [Symbol]
extract (ScopePriority Map CallPriority (CallMap a)
m) = (CallMap a -> [Symbol]) -> [CallMap a] -> [Symbol]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map Symbol a -> [Symbol]
forall k a. Map k a -> [k]
Map.keys (Map Symbol a -> [Symbol])
-> (CallMap a -> Map Symbol a) -> CallMap a -> [Symbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallMap a -> Map Symbol a
forall call. CallMap call -> Map Symbol call
call_map) (Map CallPriority (CallMap a) -> [CallMap a]
forall k a. Map k a -> [a]
Map.elems Map CallPriority (CallMap a)
m)

-- ** scale

-- | Lookup a scale_id or throw.
get_scale :: Pitch.ScaleId -> Deriver Scale
get_scale :: ScaleId -> Deriver Scale
get_scale ScaleId
scale_id =
    Deriver Scale
-> (Scale -> Deriver Scale) -> Maybe Scale -> Deriver Scale
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Deriver Scale
forall a. Stack => Text -> Deriver a
throw (Text -> Deriver Scale) -> Text -> Deriver Scale
forall a b. (a -> b) -> a -> b
$ Text
"get_scale: unknown scale: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScaleId -> Text
forall a. Pretty a => a -> Text
pretty ScaleId
scale_id) Scale -> Deriver Scale
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Maybe Scale -> Deriver Scale)
-> Deriver State Error (Maybe Scale) -> Deriver Scale
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScaleId -> Deriver State Error (Maybe Scale)
lookup_scale ScaleId
scale_id

lookup_scale :: Pitch.ScaleId -> Deriver (Maybe Scale)
lookup_scale :: ScaleId -> Deriver State Error (Maybe Scale)
lookup_scale ScaleId
scale_id = do
    LookupScale Environ -> ScaleId -> Maybe (Either PitchError Scale)
lookup <- (State -> LookupScale) -> Deriver State Error LookupScale
forall st a err. (st -> a) -> Deriver st err a
gets (Constant -> LookupScale
state_lookup_scale (Constant -> LookupScale)
-> (State -> Constant) -> State -> LookupScale
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant)
    Environ
env <- Deriver Environ
Internal.get_environ
    case Environ -> ScaleId -> Maybe (Either PitchError Scale)
lookup Environ
env ScaleId
scale_id of
        Maybe (Either PitchError Scale)
Nothing -> Maybe Scale -> Deriver State Error (Maybe Scale)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Scale
forall a. Maybe a
Nothing
        Just (Left PitchError
err) -> Text -> Deriver State Error (Maybe Scale)
forall a. Stack => Text -> Deriver a
throw (Text -> Deriver State Error (Maybe Scale))
-> Text -> Deriver State Error (Maybe Scale)
forall a b. (a -> b) -> a -> b
$ Text
"lookup " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScaleId -> Text
forall a. Pretty a => a -> Text
pretty ScaleId
scale_id Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PitchError -> Text
forall a. Pretty a => a -> Text
pretty PitchError
err
        Just (Right Scale
scale) -> Maybe Scale -> Deriver State Error (Maybe Scale)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Scale -> Deriver State Error (Maybe Scale))
-> Maybe Scale -> Deriver State Error (Maybe Scale)
forall a b. (a -> b) -> a -> b
$ Scale -> Maybe Scale
forall a. a -> Maybe a
Just Scale
scale


-- ** environment

lookup_val :: Typecheck.Typecheck a => Env.Key -> Deriver (Maybe a)
lookup_val :: forall a. Typecheck a => Text -> Deriver (Maybe a)
lookup_val Text
key =
    (Text -> Deriver State Error (Maybe a))
-> (Maybe a -> Deriver State Error (Maybe a))
-> Either Text (Maybe a)
-> Deriver State Error (Maybe a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Deriver State Error (Maybe a)
forall a. Stack => Text -> Deriver a
throw Maybe a -> Deriver State Error (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Maybe a) -> Deriver State Error (Maybe a))
-> (Environ -> Either Text (Maybe a))
-> Environ
-> Deriver State Error (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Environ -> Either Text (Maybe a)
forall a. Typecheck a => Text -> Environ -> Either Text (Maybe a)
Env.checked_val Text
key (Environ -> Deriver State Error (Maybe a))
-> Deriver Environ -> Deriver State Error (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver Environ
Internal.get_environ

is_val_set :: Env.Key -> Deriver Bool
is_val_set :: Text -> Deriver Bool
is_val_set Text
key = Maybe Val -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe Val -> Bool) -> (Environ -> Maybe Val) -> Environ -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Environ -> Maybe Val
Env.lookup Text
key (Environ -> Bool) -> Deriver Environ -> Deriver Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver Environ
Internal.get_environ

-- | Like 'lookup_val', but throw if the value isn't present.
get_val :: Typecheck.Typecheck a => Env.Key -> Deriver a
get_val :: forall a. Typecheck a => Text -> Deriver a
get_val Text
key = do
    Maybe a
val <- Text -> Deriver (Maybe a)
forall a. Typecheck a => Text -> Deriver (Maybe a)
lookup_val Text
key
    Deriver a -> (a -> Deriver a) -> Maybe a -> Deriver a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Deriver a
forall a. Stack => Text -> Deriver a
throw (Text -> Deriver a) -> Text -> Deriver a
forall a b. (a -> b) -> a -> b
$ Text
"environ val not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
pretty Text
key) a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
val

-- | Set the given val dynamically within the given computation.  This is
-- analogous to a dynamic let.
--
-- There is intentionally no way to modify the environment via assignment.
-- It would introduce an order of execution dependency that would complicate
-- caching as well as have a confusing non-local effect.
--
-- This dispatches to 'with_scale' or 'with_instrument' if it's setting the
-- scale or instrument, so scale or instrument scopes are always set when scale
-- and instrument are.
with_val :: Typecheck.ToVal val => Env.Key -> val -> Deriver a -> Deriver a
with_val :: forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val Text
key val
val Deriver a
deriver
    | Text
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
EnvKey.scale, Just ScaleId
scale_id <- Val -> Maybe ScaleId
DeriveT.to_scale_id Val
v = do
        Scale
scale <- ScaleId -> Deriver Scale
get_scale ScaleId
scale_id
        Scale -> Deriver a -> Deriver a
forall d. Scale -> Deriver d -> Deriver d
with_scale Scale
scale Deriver a
deriver
    | Text
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
EnvKey.instrument, Just Instrument
inst <- Val -> Maybe Instrument
forall a. Typecheck a => Val -> Maybe a
Typecheck.from_val_simple Val
v =
        Instrument -> Deriver a -> Deriver a
forall d. Instrument -> Deriver d -> Deriver d
with_instrument Instrument
inst Deriver a
deriver
    | Bool
otherwise = Text -> val -> Deriver a -> Deriver a
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val_raw Text
key val
val Deriver a
deriver
    where v :: Val
v = val -> Val
forall a. ToVal a => a -> Val
Typecheck.to_val val
val

-- | Like 'with_val', but should be slightly more efficient for setting
-- multiple values at once.
with_vals :: Typecheck.ToVal val => [(Env.Key, val)] -> Deriver a -> Deriver a
with_vals :: forall val a. ToVal val => [(Text, val)] -> Deriver a -> Deriver a
with_vals [(Text, val)]
vals Deriver a
deriver
    | [(Text, val)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, val)]
vals = Deriver a
deriver
    | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
EnvKey.scale, Text
EnvKey.instrument]) (((Text, val) -> Text) -> [(Text, val)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, val) -> Text
forall a b. (a, b) -> a
fst [(Text, val)]
vals) =
        ((Text, val) -> Deriver a -> Deriver a)
-> Deriver a -> [(Text, val)] -> Deriver a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Text -> val -> Deriver a -> Deriver a)
-> (Text, val) -> Deriver a -> Deriver a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> val -> Deriver a -> Deriver a
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val) Deriver a
deriver [(Text, val)]
vals
    | Bool
otherwise = (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
Internal.localm Dynamic -> Deriver Dynamic
with Deriver a
deriver
    where
    with :: Dynamic -> Deriver Dynamic
with Dynamic
state = do
        Environ
environ <- (Text -> Deriver Environ)
-> (Environ -> Deriver Environ)
-> Either Text Environ
-> Deriver Environ
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Deriver Environ
forall a. Stack => Text -> Deriver a
throw Environ -> Deriver Environ
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Environ -> Deriver Environ)
-> Either Text Environ -> Deriver Environ
forall a b. (a -> b) -> a -> b
$
            ((Text, val) -> Either Text Environ -> Either Text Environ)
-> Either Text Environ -> [(Text, val)] -> Either Text Environ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Text
k, val
v) Either Text Environ
env -> Text -> val -> Environ -> Either Text Environ
forall a. ToVal a => Text -> a -> Environ -> Either Text Environ
Env.put_val_error Text
k val
v (Environ -> Either Text Environ)
-> Either Text Environ -> Either Text Environ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either Text Environ
env)
                (Environ -> Either Text Environ
forall (m :: * -> *) a. Monad m => a -> m a
return (Environ -> Either Text Environ) -> Environ -> Either Text Environ
forall a b. (a -> b) -> a -> b
$ Dynamic -> Environ
state_environ Dynamic
state) [(Text, val)]
vals
        Environ
environ Environ -> Deriver Dynamic -> Deriver Dynamic
`seq` Dynamic -> Deriver Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic -> Deriver Dynamic) -> Dynamic -> Deriver Dynamic
forall a b. (a -> b) -> a -> b
$! Dynamic
state { state_environ :: Environ
state_environ = Environ
environ }

-- | Merge the given environ into the environ in effect.  Unlike 'with_val' or
-- 'with_vals', this won't set scopes for 'EnvKey.scale' and
-- 'EnvKey.instrument'.
with_environ :: Env.Environ -> Deriver a -> Deriver a
with_environ :: forall d. Environ -> Deriver d -> Deriver d
with_environ Environ
environ
    | Environ -> Bool
Env.null Environ
environ = Deriver a -> Deriver a
forall a. a -> a
id
    | Bool
otherwise = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
        { state_environ :: Environ
state_environ = Environ
environ Environ -> Environ -> Environ
forall a. Semigroup a => a -> a -> a
<> Dynamic -> Environ
state_environ Dynamic
state }

-- | Like 'with_val', but don't set scopes for instrument and scale.
with_val_raw :: Typecheck.ToVal val => Env.Key -> val -> Deriver a -> Deriver a
with_val_raw :: forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val_raw Text
key val
val = (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
Internal.localm ((Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> do
    Environ
environ <- Text -> val -> Environ -> Deriver Environ
forall {a}. ToVal a => Text -> a -> Environ -> Deriver Environ
insert_environ Text
key val
val (Dynamic -> Environ
state_environ Dynamic
state)
    Environ
environ Environ -> Deriver Dynamic -> Deriver Dynamic
`seq` Dynamic -> Deriver Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic -> Deriver Dynamic) -> Dynamic -> Deriver Dynamic
forall a b. (a -> b) -> a -> b
$! Dynamic
state { state_environ :: Environ
state_environ = Environ
environ }
    where insert_environ :: Text -> a -> Environ -> Deriver Environ
insert_environ Text
key a
val = (Text -> Text) -> Either Text Environ -> Deriver Environ
forall err a. Stack => (err -> Text) -> Either err a -> Deriver a
require_right Text -> Text
forall a. a -> a
id (Either Text Environ -> Deriver Environ)
-> (Environ -> Either Text Environ) -> Environ -> Deriver Environ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> a -> Environ -> Either Text Environ
forall a. ToVal a => Text -> a -> Environ -> Either Text Environ
Env.put_val_error Text
key a
val

delete_val :: Env.Key -> Deriver a -> Deriver a
delete_val :: forall a. Text -> Deriver a -> Deriver a
delete_val Text
key = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state ->
    Dynamic
state { state_environ :: Environ
state_environ = Text -> Environ -> Environ
Env.delete Text
key (Environ -> Environ) -> Environ -> Environ
forall a b. (a -> b) -> a -> b
$ Dynamic -> Environ
state_environ Dynamic
state }

-- | This is the Env version of with_merged_control.  It only works on numeric
-- env vals.
with_merged_numeric_val :: Merger -> Env.Key -> Signal.Y
    -> Deriver a -> Deriver a
with_merged_numeric_val :: forall a. Merger -> Text -> Y -> Deriver a -> Deriver a
with_merged_numeric_val Merger
merger Text
key Y
val = case Merger
merger of
    Merger
Set -> Text -> Y -> Deriver a -> Deriver a
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val Text
key Y
val
    Merger
Unset -> \Deriver a
deriver -> do
        Maybe Y
old <- Text -> Deriver (Maybe Y)
forall a. Typecheck a => Text -> Deriver (Maybe a)
lookup_val Text
key -- throw if not numeric
        if (Maybe Y
old :: Maybe Signal.Y) Maybe Y -> Maybe Y -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Y
forall a. Maybe a
Nothing
            then Text -> Y -> Deriver a -> Deriver a
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val Text
key Y
val Deriver a
deriver
            else Deriver a
deriver
    Merger Text
name Control -> Control -> Control
merge Y
ident -> (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
Internal.localm ((Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> do
        (Type
typ, Y
old) <- case Text -> Environ -> Maybe (Either Text (Typed Y))
forall a. Typecheck a => Text -> Environ -> Maybe (Either Text a)
Env.checked_val2 Text
key (Dynamic -> Environ
state_environ Dynamic
state) of
            Maybe (Either Text (Typed Y))
Nothing -> (Type, Y) -> Deriver State Error (Type, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ScoreT.Untyped, Y
ident)
            Just (Right (ScoreT.Typed Type
typ Y
old)) -> (Type, Y) -> Deriver State Error (Type, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
typ, Y
old)
            Just (Left Text
err) -> Text -> Deriver State Error (Type, Y)
forall a. Stack => Text -> Deriver a
throw Text
err
        -- This is a hack to reuse Merger, which is defined on Signal, not Y.
        -- It could be defined on Y, but then I'd have to directly use
        -- Signal.linear_operator instead of Signal.sig_add, and I don't trust
        -- that I'll never have a non-linear merger.
        Y
new <- Text -> Maybe Y -> Deriver Y
forall a. Stack => Text -> Maybe a -> Deriver a
require (Text
"merger " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" produced an empty signal") (Maybe Y -> Deriver Y) -> Maybe Y -> Deriver Y
forall a b. (a -> b) -> a -> b
$
            Control -> Maybe Y
forall {k} (kind :: k). Signal kind -> Maybe Y
Signal.constant_val (Control -> Maybe Y) -> Control -> Maybe Y
forall a b. (a -> b) -> a -> b
$
            Control -> Control -> Control
merge (Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
old) (Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
val)
        Dynamic -> Deriver Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic -> Deriver Dynamic) -> Dynamic -> Deriver Dynamic
forall a b. (a -> b) -> a -> b
$! Text -> Typed Y -> Dynamic -> Dynamic
forall val. ToVal val => Text -> val -> Dynamic -> Dynamic
insert_env Text
key (Type -> Y -> Typed Y
forall a. Type -> a -> Typed a
ScoreT.Typed Type
typ Y
new) Dynamic
state

modify_val :: (Typecheck.Typecheck val, Typecheck.ToVal val) => Env.Key
    -> (Maybe val -> val) -> Deriver a -> Deriver a
modify_val :: forall val a.
(Typecheck val, ToVal val) =>
Text -> (Maybe val -> val) -> Deriver a -> Deriver a
modify_val Text
key Maybe val -> val
modify = (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
Internal.localm ((Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> do
    val
val <- Maybe val -> val
modify (Maybe val -> val)
-> Deriver State Error (Maybe val) -> Deriver State Error val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Text -> Text)
-> Either Text (Maybe val) -> Deriver State Error (Maybe val)
forall err a. Stack => (err -> Text) -> Either err a -> Deriver a
require_right Text -> Text
forall a. a -> a
id (Text -> Environ -> Either Text (Maybe val)
forall a. Typecheck a => Text -> Environ -> Either Text (Maybe a)
Env.checked_val Text
key (Dynamic -> Environ
state_environ Dynamic
state))
    Dynamic -> Deriver Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic -> Deriver Dynamic) -> Dynamic -> Deriver Dynamic
forall a b. (a -> b) -> a -> b
$! Text -> val -> Dynamic -> Dynamic
forall val. ToVal val => Text -> val -> Dynamic -> Dynamic
insert_env Text
key val
val Dynamic
state

insert_env :: Typecheck.ToVal val => Env.Key -> val -> Dynamic -> Dynamic
insert_env :: forall val. ToVal val => Text -> val -> Dynamic -> Dynamic
insert_env Text
key val
val Dynamic
state = Dynamic
state
    { state_environ :: Environ
state_environ =
        Text -> Val -> Environ -> Environ
forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
key (val -> Val
forall a. ToVal a => a -> Val
Typecheck.to_val val
val) (Dynamic -> Environ
state_environ Dynamic
state)
    }

-- | Replace the scale's calls.
--
-- Previously this used 'add_priority' instead of 'replace_priority', which
-- meant you could overlay scales and use both at the same time.  Maybe that's
-- actually a useful feature?  In any case, I don't need it at the moment, so
-- it seems more likely to be confusing than useful.
with_scale :: Scale -> Deriver d -> Deriver d
with_scale :: forall d. Scale -> Deriver d -> Deriver d
with_scale Scale
scale Deriver d
deriver =
    Text -> Str -> Deriver d -> Deriver d
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val_raw Text
EnvKey.scale (ScaleId -> Str
Expr.scale_id_to_str (Scale -> ScaleId
scale_id Scale
scale)) (Deriver d -> Deriver d) -> Deriver d -> Deriver d
forall a b. (a -> b) -> a -> b
$
        (Scopes -> Scopes) -> Deriver d -> Deriver d
forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
with_scopes (Scopes -> Scopes
forall {gen} {trans} {track}.
ScopesT gen trans track (ScopePriority ValCall)
-> ScopesT gen trans track (ScopePriority ValCall)
val (Scopes -> Scopes) -> (Scopes -> Scopes) -> Scopes -> Scopes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes -> Scopes
forall {note} {control} {trans} {track} {val}.
ScopesT
  (Scope note control (ScopePriority (Generator Pitch)))
  trans
  track
  val
-> ScopesT
     (Scope note control (ScopePriority (Generator Pitch)))
     trans
     track
     val
pitch) Deriver d
deriver
    where
    pitch :: ScopesT
  (Scope note control (ScopePriority (Generator Pitch)))
  trans
  track
  val
-> ScopesT
     (Scope note control (ScopePriority (Generator Pitch)))
     trans
     track
     val
pitch = ScopesT
  (Scope note control (ScopePriority (Generator Pitch)))
  trans
  track
  val
:-> Scope note control (ScopePriority (Generator Pitch))
forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> gen
s_generator(ScopesT
   (Scope note control (ScopePriority (Generator Pitch)))
   trans
   track
   val
 :-> Scope note control (ScopePriority (Generator Pitch)))
-> Lens
     (Scope note control (ScopePriority (Generator Pitch)))
     (ScopePriority (Generator Pitch))
-> Lens
     (ScopesT
        (Scope note control (ScopePriority (Generator Pitch)))
        trans
        track
        val)
     (ScopePriority (Generator Pitch))
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens
  (Scope note control (ScopePriority (Generator Pitch)))
  (ScopePriority (Generator Pitch))
forall {note} {control} {pitch}. Scope note control pitch :-> pitch
s_pitch Lens
  (ScopesT
     (Scope note control (ScopePriority (Generator Pitch)))
     trans
     track
     val)
  (ScopePriority (Generator Pitch))
-> (ScopePriority (Generator Pitch)
    -> ScopePriority (Generator Pitch))
-> ScopesT
     (Scope note control (ScopePriority (Generator Pitch)))
     trans
     track
     val
-> ScopesT
     (Scope note control (ScopePriority (Generator Pitch)))
     trans
     track
     val
forall f a. Lens f a -> (a -> a) -> f -> f
%= PatternCall (Generator Pitch)
-> ScopePriority (Generator Pitch)
-> ScopePriority (Generator Pitch)
forall {call}.
PatternCall call -> ScopePriority call -> ScopePriority call
replace (Scale
-> (ValCall -> Generator Pitch) -> PatternCall (Generator Pitch)
forall call. Scale -> (ValCall -> call) -> PatternCall call
scale_to_call Scale
scale ValCall -> Generator Pitch
val_to_pitch)
    val :: ScopesT gen trans track (ScopePriority ValCall)
-> ScopesT gen trans track (ScopePriority ValCall)
val = ScopesT gen trans track (ScopePriority ValCall)
:-> ScopePriority ValCall
forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> val
s_val (ScopesT gen trans track (ScopePriority ValCall)
 :-> ScopePriority ValCall)
-> (ScopePriority ValCall -> ScopePriority ValCall)
-> ScopesT gen trans track (ScopePriority ValCall)
-> ScopesT gen trans track (ScopePriority ValCall)
forall f a. Lens f a -> (a -> a) -> f -> f
%= PatternCall ValCall
-> ScopePriority ValCall -> ScopePriority ValCall
forall {call}.
PatternCall call -> ScopePriority call -> ScopePriority call
replace (Scale -> (ValCall -> ValCall) -> PatternCall ValCall
forall call. Scale -> (ValCall -> call) -> PatternCall call
scale_to_call Scale
scale ValCall -> ValCall
forall a. a -> a
id)
    replace :: PatternCall call -> ScopePriority call -> ScopePriority call
replace PatternCall call
pattern =
        CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
replace_priority CallPriority
PrioScale (CallMap call
forall a. Monoid a => a
mempty { call_patterns :: [PatternCall call]
call_patterns = [PatternCall call
pattern] })

scale_to_call :: Scale -> (ValCall -> call) -> PatternCall call
scale_to_call :: forall call. Scale -> (ValCall -> call) -> PatternCall call
scale_to_call Scale
scale ValCall -> call
convert = PatternCall
    { pat_description :: Text
pat_description = Text
description
    , pat_doc :: DocumentedCall
pat_doc = Scale -> DocumentedCall
scale_call_doc Scale
scale
    , pat_function :: Symbol -> Deriver (Maybe call)
pat_function = \Symbol
sym ->
        Maybe call -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe call -> Deriver (Maybe call))
-> Maybe call -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$ ValCall -> call
convert (ValCall -> call) -> Maybe ValCall -> Maybe call
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scale -> Note -> Maybe ValCall
scale_note_to_call Scale
scale (Symbol -> Note
to_note Symbol
sym)
    }
    where
    description :: Text
description = ScaleId -> Text
forall a. Pretty a => a -> Text
pretty (Scale -> ScaleId
scale_id Scale
scale) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Scale -> Text
scale_pattern Scale
scale
    to_note :: Symbol -> Note
to_note (Expr.Symbol Text
sym) = Text -> Note
Pitch.Note Text
sym

-- | Convert a val call to a pitch call.  This is used so scales can export
-- their ValCalls to pitch generators.
val_to_pitch :: ValCall -> Generator Pitch
val_to_pitch :: ValCall -> Generator Pitch
val_to_pitch (ValCall CallName
name CallDoc
doc PassedArgs Tagged -> Deriver Val
vcall) = Call
    { call_name :: CallName
call_name = CallName
name
    , call_doc :: CallDoc
call_doc = CallDoc
doc
    , call_func :: GeneratorFunc Pitch
call_func = (PassedArgs Pitch -> Deriver (Stream Pitch)) -> GeneratorFunc Pitch
forall d. (PassedArgs d -> Deriver (Stream d)) -> GeneratorFunc d
generator_func PassedArgs Pitch -> Deriver (Stream Pitch)
pitch_call
    }
    where
    convert_args :: PassedArgs a -> PassedArgs Tagged
convert_args PassedArgs a
args = PassedArgs a
args { passed_ctx :: Context Tagged
passed_ctx = Context a -> Context Tagged
forall a. Taggable a => Context a -> Context Tagged
tag_context (PassedArgs a -> Context a
forall val. PassedArgs val -> Context val
passed_ctx PassedArgs a
args) }
    pitch_call :: PassedArgs Pitch -> Deriver (Stream Pitch)
pitch_call PassedArgs Pitch
args = PassedArgs Tagged -> Deriver Val
vcall (PassedArgs Pitch -> PassedArgs Tagged
forall {a}. Taggable a => PassedArgs a -> PassedArgs Tagged
convert_args PassedArgs Pitch
args) Deriver Val
-> (Val -> Deriver (Stream Pitch)) -> Deriver (Stream Pitch)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Val
val -> case Val
val of
        DeriveT.VPitch Pitch
pitch -> Symbol -> Deriver (Maybe (Generator Pitch))
forall call. Callable call => Symbol -> Deriver (Maybe call)
lookup_call Symbol
Symbols.default_pitch Deriver (Maybe (Generator Pitch))
-> (Maybe (Generator Pitch) -> Deriver (Stream Pitch))
-> Deriver (Stream Pitch)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (Generator Pitch)
Nothing -> PassedArgs Pitch -> Pitch -> Deriver (Stream Pitch)
forall val. PassedArgs val -> Pitch -> Deriver (Stream Pitch)
default_pitch_call PassedArgs Pitch
args Pitch
pitch
            Just Generator Pitch
pcall -> GeneratorFunc Pitch -> PassedArgs Pitch -> Deriver (Stream Pitch)
forall d. GeneratorFunc d -> GeneratorF d
gfunc_f (Generator Pitch -> GeneratorFunc Pitch
forall func. Call func -> func
call_func Generator Pitch
pcall) (PassedArgs Pitch -> Deriver (Stream Pitch))
-> PassedArgs Pitch -> Deriver (Stream Pitch)
forall a b. (a -> b) -> a -> b
$ PassedArgs
                { passed_vals :: [Val]
passed_vals = [Pitch -> Val
DeriveT.VPitch Pitch
pitch]
                , passed_call_name :: CallName
passed_call_name = Generator Pitch -> CallName
forall func. Call func -> CallName
call_name Generator Pitch
pcall
                , passed_ctx :: Context Pitch
passed_ctx = PassedArgs Pitch -> Context Pitch
forall val. PassedArgs val -> Context val
passed_ctx PassedArgs Pitch
args
                }
        Val
_ -> Text -> Deriver (Stream Pitch)
forall a. Stack => Text -> Deriver a
throw (Text -> Deriver (Stream Pitch)) -> Text -> Deriver (Stream Pitch)
forall a b. (a -> b) -> a -> b
$ Text
"scale call " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CallName -> Text
forall a. Pretty a => a -> Text
pretty CallName
name
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" returned non-pitch: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Val -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Val
val

-- | This is the default pitch call for bare scale degrees if
-- 'Symbols.default_pitch' isn't set.
default_pitch_call :: PassedArgs val -> PSignal.Pitch
    -> Deriver (Stream.Stream PSignal.PSignal)
default_pitch_call :: forall val. PassedArgs val -> Pitch -> Deriver (Stream Pitch)
default_pitch_call PassedArgs val
args Pitch
pitch = do
    -- This is Args.real, but I can't import it here.
    RealTime
pos <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Internal.real (ScoreTime -> Deriver RealTime) -> ScoreTime -> Deriver RealTime
forall a b. (a -> b) -> a -> b
$ Event -> ScoreTime
Event.start (Event -> ScoreTime) -> Event -> ScoreTime
forall a b. (a -> b) -> a -> b
$ Context val -> Event
forall val. Context val -> Event
ctx_event (Context val -> Event) -> Context val -> Event
forall a b. (a -> b) -> a -> b
$ PassedArgs val -> Context val
forall val. PassedArgs val -> Context val
passed_ctx PassedArgs val
args
    Stream Pitch -> Deriver (Stream Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream Pitch -> Deriver (Stream Pitch))
-> Stream Pitch -> Deriver (Stream Pitch)
forall a b. (a -> b) -> a -> b
$ Pitch -> Stream Pitch
forall a. a -> Stream a
Stream.from_event (Pitch -> Stream Pitch) -> Pitch -> Stream Pitch
forall a b. (a -> b) -> a -> b
$ RealTime -> Pitch -> Pitch
PSignal.from_sample RealTime
pos Pitch
pitch

-- | Run the a deriver with the given instrument in scope.  In addition to
-- assigning the instrument to the 'EnvKey.instrument' field where note calls
-- can inherit it, this also brings the 'Instrument' fields into scope, which
-- is the per-instrument calls and per-instrument environ.
with_instrument :: ScoreT.Instrument -> Deriver d -> Deriver d
with_instrument :: forall d. Instrument -> Deriver d -> Deriver d
with_instrument Instrument
inst Deriver d
deriver = do
    -- Previously, I would just substitute an empty instrument instead of
    -- throwing, but it turned out to be error prone, since a misspelled
    -- instrument would derive anyway, only without the right calls and
    -- environ.
    (Instrument
inst, Instrument
derive_inst) <- Instrument -> Deriver (Instrument, Instrument)
get_instrument Instrument
inst
    let with_inst :: Deriver a -> Deriver a
with_inst = Text -> Instrument -> Deriver a -> Deriver a
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val_raw Text
EnvKey.instrument Instrument
inst
    let with_scale :: Deriver a -> Deriver a
with_scale = (Deriver a -> Deriver a)
-> (Val -> Deriver a -> Deriver a)
-> Maybe Val
-> Deriver a
-> Deriver a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Deriver a -> Deriver a
forall a. a -> a
id (Text -> Val -> Deriver a -> Deriver a
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val Text
EnvKey.scale) (Maybe Val -> Deriver a -> Deriver a)
-> Maybe Val -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$
            Text -> Environ -> Maybe Val
Env.lookup Text
EnvKey.scale (Instrument -> Environ
inst_environ Instrument
derive_inst)
    Deriver d -> Deriver d
forall a. Deriver a -> Deriver a
with_inst (Deriver d -> Deriver d) -> Deriver d -> Deriver d
forall a b. (a -> b) -> a -> b
$ (Scopes -> Scopes) -> Deriver d -> Deriver d
forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
with_scopes (ScopesT
  (CallMap (Generator Event))
  (CallMap (Transformer Event))
  (CallMap (TrackCall Event))
  (CallMap ValCall)
-> Scopes -> Scopes
forall {call} {call} {call} {call} {control} {pitch} {control}
       {pitch} {control} {pitch}.
ScopesT (CallMap call) (CallMap call) (CallMap call) (CallMap call)
-> ScopesT
     (Scope (ScopePriority call) control pitch)
     (Scope (ScopePriority call) control pitch)
     (Scope (ScopePriority call) control pitch)
     (ScopePriority call)
-> ScopesT
     (Scope (ScopePriority call) control pitch)
     (Scope (ScopePriority call) control pitch)
     (Scope (ScopePriority call) control pitch)
     (ScopePriority call)
set_scopes (Instrument
-> ScopesT
     (CallMap (Generator Event))
     (CallMap (Transformer Event))
     (CallMap (TrackCall Event))
     (CallMap ValCall)
inst_calls Instrument
derive_inst)) (Deriver d -> Deriver d) -> Deriver d -> Deriver d
forall a b. (a -> b) -> a -> b
$
        Deriver d -> Deriver d
forall a. Deriver a -> Deriver a
with_scale (Deriver d -> Deriver d) -> Deriver d -> Deriver d
forall a b. (a -> b) -> a -> b
$ Environ -> Deriver d -> Deriver d
forall d. Environ -> Deriver d -> Deriver d
with_environ (Instrument -> Environ
inst_environ Instrument
derive_inst) Deriver d
deriver
    where
    -- Replace the calls in the instrument scope type.
    set_scopes :: ScopesT (CallMap call) (CallMap call) (CallMap call) (CallMap call)
-> ScopesT
     (Scope (ScopePriority call) control pitch)
     (Scope (ScopePriority call) control pitch)
     (Scope (ScopePriority call) control pitch)
     (ScopePriority call)
-> ScopesT
     (Scope (ScopePriority call) control pitch)
     (Scope (ScopePriority call) control pitch)
     (Scope (ScopePriority call) control pitch)
     (ScopePriority call)
set_scopes (Scopes CallMap call
inst_gen CallMap call
inst_trans CallMap call
inst_track CallMap call
inst_val)
            (Scopes Scope (ScopePriority call) control pitch
gen Scope (ScopePriority call) control pitch
trans Scope (ScopePriority call) control pitch
track ScopePriority call
val) =
        Scopes
            { scopes_generator :: Scope (ScopePriority call) control pitch
scopes_generator = (Scope (ScopePriority call) control pitch :-> ScopePriority call
forall {note} {control} {pitch}. Scope note control pitch :-> note
s_note (Scope (ScopePriority call) control pitch :-> ScopePriority call)
-> (ScopePriority call -> ScopePriority call)
-> Scope (ScopePriority call) control pitch
-> Scope (ScopePriority call) control pitch
forall f a. Lens f a -> (a -> a) -> f -> f
%= CallMap call -> ScopePriority call -> ScopePriority call
forall {call}.
CallMap call -> ScopePriority call -> ScopePriority call
replace CallMap call
inst_gen) Scope (ScopePriority call) control pitch
gen
            , scopes_transformer :: Scope (ScopePriority call) control pitch
scopes_transformer = (Scope (ScopePriority call) control pitch :-> ScopePriority call
forall {note} {control} {pitch}. Scope note control pitch :-> note
s_note (Scope (ScopePriority call) control pitch :-> ScopePriority call)
-> (ScopePriority call -> ScopePriority call)
-> Scope (ScopePriority call) control pitch
-> Scope (ScopePriority call) control pitch
forall f a. Lens f a -> (a -> a) -> f -> f
%= CallMap call -> ScopePriority call -> ScopePriority call
forall {call}.
CallMap call -> ScopePriority call -> ScopePriority call
replace CallMap call
inst_trans) Scope (ScopePriority call) control pitch
trans
            , scopes_track :: Scope (ScopePriority call) control pitch
scopes_track = (Scope (ScopePriority call) control pitch :-> ScopePriority call
forall {note} {control} {pitch}. Scope note control pitch :-> note
s_note (Scope (ScopePriority call) control pitch :-> ScopePriority call)
-> (ScopePriority call -> ScopePriority call)
-> Scope (ScopePriority call) control pitch
-> Scope (ScopePriority call) control pitch
forall f a. Lens f a -> (a -> a) -> f -> f
%= CallMap call -> ScopePriority call -> ScopePriority call
forall {call}.
CallMap call -> ScopePriority call -> ScopePriority call
replace CallMap call
inst_track) Scope (ScopePriority call) control pitch
track
            , scopes_val :: ScopePriority call
scopes_val = CallMap call -> ScopePriority call -> ScopePriority call
forall {call}.
CallMap call -> ScopePriority call -> ScopePriority call
replace CallMap call
inst_val ScopePriority call
val
            }
    replace :: CallMap call -> ScopePriority call -> ScopePriority call
replace = CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
replace_priority CallPriority
PrioInstrument

with_instrument_alias :: ScoreT.Instrument -> ScoreT.Instrument
    -> Deriver a -> Deriver a
with_instrument_alias :: forall a. Instrument -> Instrument -> Deriver a -> Deriver a
with_instrument_alias Instrument
alias Instrument
inst =
    Map Instrument Instrument -> Deriver a -> Deriver a
forall a. Map Instrument Instrument -> Deriver a -> Deriver a
with_instrument_aliases (Instrument -> Instrument -> Map Instrument Instrument
forall k a. k -> a -> Map k a
Map.singleton Instrument
alias Instrument
inst)

with_instrument_aliases :: Map ScoreT.Instrument ScoreT.Instrument
    -> Deriver a -> Deriver a
with_instrument_aliases :: forall a. Map Instrument Instrument -> Deriver a -> Deriver a
with_instrument_aliases Map Instrument Instrument
aliases Deriver a
deriver
    | Map Instrument Instrument -> Bool
forall k a. Map k a -> Bool
Map.null Map Instrument Instrument
aliases = Deriver a
deriver
    -- I used to verify that the rhs insts exist, but verification can be
    -- annoying if there is a library ky that creates some general purpose
    -- aliases, e.g. >r{1..4} = >r.
    | Bool
otherwise = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local Dynamic -> Dynamic
with Deriver a
deriver
    where
    with :: Dynamic -> Dynamic
with Dynamic
state = Dynamic
state
        { state_instrument_aliases :: Map Instrument Instrument
state_instrument_aliases = (Instrument -> Instrument
resolve (Instrument -> Instrument)
-> Map Instrument Instrument -> Map Instrument Instrument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Instrument Instrument
aliases) Map Instrument Instrument
-> Map Instrument Instrument -> Map Instrument Instrument
forall a. Semigroup a => a -> a -> a
<> Map Instrument Instrument
old_aliases }
        where
        old_aliases :: Map Instrument Instrument
old_aliases = Dynamic -> Map Instrument Instrument
state_instrument_aliases Dynamic
state
        resolve :: Instrument -> Instrument
resolve Instrument
inst = Instrument -> Instrument -> Map Instrument Instrument -> Instrument
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Instrument
inst Instrument
inst Map Instrument Instrument
old_aliases

instrument_exists :: ScoreT.Instrument -> Deriver Bool
instrument_exists :: Instrument -> Deriver Bool
instrument_exists = (Either Text Instrument -> Bool
forall a b. Either a b -> Bool
Either.isRight (Either Text Instrument -> Bool)
-> ((Instrument, Either Text Instrument) -> Either Text Instrument)
-> (Instrument, Either Text Instrument)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Instrument, Either Text Instrument) -> Either Text Instrument
forall a b. (a, b) -> b
snd <$>) (Deriver State Error (Instrument, Either Text Instrument)
 -> Deriver Bool)
-> (Instrument
    -> Deriver State Error (Instrument, Either Text Instrument))
-> Instrument
-> Deriver Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instrument
-> Deriver State Error (Instrument, Either Text Instrument)
lookup_instrument

get_instrument :: ScoreT.Instrument -> Deriver (ScoreT.Instrument, Instrument)
get_instrument :: Instrument -> Deriver (Instrument, Instrument)
get_instrument Instrument
score_inst = do
    (Instrument
real_inst, Either Text Instrument
result) <- Instrument
-> Deriver State Error (Instrument, Either Text Instrument)
lookup_instrument Instrument
score_inst
    case Either Text Instrument
result of
        Left Text
err -> Text -> Deriver (Instrument, Instrument)
forall a. Stack => Text -> Deriver a
throw (Text -> Deriver (Instrument, Instrument))
-> Text -> Deriver (Instrument, Instrument)
forall a b. (a -> b) -> a -> b
$ Text
"instrument "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Instrument
real_inst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"': " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Instrument
real_inst Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
== Instrument
score_inst then Text
""
                else Text
" (aliased from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Instrument
score_inst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        Right Instrument
inst -> (Instrument, Instrument) -> Deriver (Instrument, Instrument)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instrument
real_inst, Instrument
inst)

-- | Look up the instrument.  Also return the instrument name after resolving
-- any alias.  This is what goes in 'Score.event_instrument', since it's what
-- the performer understands.
lookup_instrument :: ScoreT.Instrument
    -> Deriver (ScoreT.Instrument, Either Text Instrument)
lookup_instrument :: Instrument
-> Deriver State Error (Instrument, Either Text Instrument)
lookup_instrument Instrument
inst = do
    Map Instrument Instrument
aliases <- (Dynamic -> Map Instrument Instrument)
-> Deriver (Map Instrument Instrument)
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Map Instrument Instrument
state_instrument_aliases
    let real_inst :: Instrument
real_inst = Instrument -> Instrument -> Map Instrument Instrument -> Instrument
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Instrument
inst Instrument
inst Map Instrument Instrument
aliases
    Instrument -> Either Text Instrument
lookup_inst <- (State -> Instrument -> Either Text Instrument)
-> Deriver State Error (Instrument -> Either Text Instrument)
forall st a err. (st -> a) -> Deriver st err a
gets ((State -> Instrument -> Either Text Instrument)
 -> Deriver State Error (Instrument -> Either Text Instrument))
-> (State -> Instrument -> Either Text Instrument)
-> Deriver State Error (Instrument -> Either Text Instrument)
forall a b. (a -> b) -> a -> b
$ Constant -> Instrument -> Either Text Instrument
state_lookup_instrument (Constant -> Instrument -> Either Text Instrument)
-> (State -> Constant)
-> State
-> Instrument
-> Either Text Instrument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant
    (Instrument, Either Text Instrument)
-> Deriver State Error (Instrument, Either Text Instrument)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instrument
real_inst, Instrument -> Either Text Instrument
lookup_inst Instrument
real_inst)


-- ** control

-- | Return an entire signal.
lookup_control :: ScoreT.Control
    -> Deriver (Maybe (RealTime -> ScoreT.Typed Signal.Y))
lookup_control :: Control -> Deriver (Maybe (RealTime -> Typed Y))
lookup_control Control
control = Control -> Deriver (Maybe (RealTime -> Typed Y))
lookup_control_function Control
control Deriver (Maybe (RealTime -> Typed Y))
-> (Maybe (RealTime -> Typed Y)
    -> Deriver (Maybe (RealTime -> Typed Y)))
-> Deriver (Maybe (RealTime -> Typed Y))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just RealTime -> Typed Y
f -> Maybe (RealTime -> Typed Y)
-> Deriver (Maybe (RealTime -> Typed Y))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RealTime -> Typed Y)
 -> Deriver (Maybe (RealTime -> Typed Y)))
-> Maybe (RealTime -> Typed Y)
-> Deriver (Maybe (RealTime -> Typed Y))
forall a b. (a -> b) -> a -> b
$ (RealTime -> Typed Y) -> Maybe (RealTime -> Typed Y)
forall a. a -> Maybe a
Just RealTime -> Typed Y
f
    Maybe (RealTime -> Typed Y)
Nothing -> Control -> Deriver (Maybe (Typed Control))
lookup_control_signal Control
control Deriver (Maybe (Typed Control))
-> (Maybe (Typed Control) -> Deriver (Maybe (RealTime -> Typed Y)))
-> Deriver (Maybe (RealTime -> Typed Y))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (RealTime -> Typed Y)
-> Deriver (Maybe (RealTime -> Typed Y))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RealTime -> Typed Y)
 -> Deriver (Maybe (RealTime -> Typed Y)))
-> (Maybe (Typed Control) -> Maybe (RealTime -> Typed Y))
-> Maybe (Typed Control)
-> Deriver (Maybe (RealTime -> Typed Y))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Typed Control -> RealTime -> Typed Y)
-> Maybe (Typed Control) -> Maybe (RealTime -> Typed Y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Typed Control -> RealTime -> Typed Y
signal_function

is_control_set :: ScoreT.Control -> Deriver Bool
is_control_set :: Control -> Deriver Bool
is_control_set = (Maybe (RealTime -> Typed Y) -> Bool)
-> Deriver (Maybe (RealTime -> Typed Y)) -> Deriver Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (RealTime -> Typed Y) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Deriver (Maybe (RealTime -> Typed Y)) -> Deriver Bool)
-> (Control -> Deriver (Maybe (RealTime -> Typed Y)))
-> Control
-> Deriver Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Deriver (Maybe (RealTime -> Typed Y))
lookup_control

signal_function :: ScoreT.Typed Signal.Control
    -> (RealTime -> ScoreT.Typed Signal.Y)
signal_function :: Typed Control -> RealTime -> Typed Y
signal_function Typed Control
sig RealTime
t = RealTime -> Control -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
t (Control -> Y) -> Typed Control -> Typed Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Control
sig

lookup_control_signal :: ScoreT.Control
    -> Deriver (Maybe (ScoreT.Typed Signal.Control))
lookup_control_signal :: Control -> Deriver (Maybe (Typed Control))
lookup_control_signal Control
control = Control -> Map Control (Typed Control) -> Maybe (Typed Control)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control (Map Control (Typed Control) -> Maybe (Typed Control))
-> Deriver State Error (Map Control (Typed Control))
-> Deriver (Maybe (Typed Control))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error (Map Control (Typed Control))
get_controls

get_controls :: Deriver DeriveT.ControlMap
get_controls :: Deriver State Error (Map Control (Typed Control))
get_controls = (Dynamic -> Map Control (Typed Control))
-> Deriver State Error (Map Control (Typed Control))
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Map Control (Typed Control)
state_controls

get_control_functions :: Deriver DeriveT.ControlFunctionMap
get_control_functions :: Deriver ControlFunctionMap
get_control_functions = (Dynamic -> ControlFunctionMap) -> Deriver ControlFunctionMap
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> ControlFunctionMap
state_control_functions

-- | Get the control value at the given time, taking 'state_control_functions'
-- into account.
control_at :: ScoreT.Control -> RealTime
    -> Deriver (Maybe (ScoreT.Typed Signal.Y))
control_at :: Control -> RealTime -> Deriver (Maybe (Typed Y))
control_at Control
control RealTime
pos = Control -> Deriver (Maybe (RealTime -> Typed Y))
lookup_control_function Control
control Deriver (Maybe (RealTime -> Typed Y))
-> (Maybe (RealTime -> Typed Y) -> Deriver (Maybe (Typed Y)))
-> Deriver (Maybe (Typed Y))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just RealTime -> Typed Y
f -> Maybe (Typed Y) -> Deriver (Maybe (Typed Y))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Typed Y) -> Deriver (Maybe (Typed Y)))
-> Maybe (Typed Y) -> Deriver (Maybe (Typed Y))
forall a b. (a -> b) -> a -> b
$ Typed Y -> Maybe (Typed Y)
forall a. a -> Maybe a
Just (Typed Y -> Maybe (Typed Y)) -> Typed Y -> Maybe (Typed Y)
forall a b. (a -> b) -> a -> b
$ RealTime -> Typed Y
f RealTime
pos
    Maybe (RealTime -> Typed Y)
Nothing -> do
        Maybe (Typed Control)
maybe_sig <- Control -> Map Control (Typed Control) -> Maybe (Typed Control)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control (Map Control (Typed Control) -> Maybe (Typed Control))
-> Deriver State Error (Map Control (Typed Control))
-> Deriver (Maybe (Typed Control))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error (Map Control (Typed Control))
get_controls
        Maybe (Typed Y) -> Deriver (Maybe (Typed Y))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Typed Y) -> Deriver (Maybe (Typed Y)))
-> Maybe (Typed Y) -> Deriver (Maybe (Typed Y))
forall a b. (a -> b) -> a -> b
$ (Control -> Y) -> Typed Control -> Typed Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> Control -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
pos) (Typed Control -> Typed Y)
-> Maybe (Typed Control) -> Maybe (Typed Y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Typed Control)
maybe_sig

lookup_control_function :: ScoreT.Control
    -> Deriver (Maybe (RealTime -> ScoreT.Typed Signal.Y))
lookup_control_function :: Control -> Deriver (Maybe (RealTime -> Typed Y))
lookup_control_function Control
control = do
    ControlFunctionMap
functions <- (Dynamic -> ControlFunctionMap) -> Deriver ControlFunctionMap
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> ControlFunctionMap
state_control_functions
    case Control -> ControlFunctionMap -> Maybe ControlFunction
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control ControlFunctionMap
functions of
        Maybe ControlFunction
Nothing -> Maybe (RealTime -> Typed Y)
-> Deriver (Maybe (RealTime -> Typed Y))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RealTime -> Typed Y)
forall a. Maybe a
Nothing
        Just ControlFunction
f -> do
            Dynamic
dyn <- Deriver Dynamic
Internal.get_control_function_dynamic
            Maybe (RealTime -> Typed Y)
-> Deriver (Maybe (RealTime -> Typed Y))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RealTime -> Typed Y)
 -> Deriver (Maybe (RealTime -> Typed Y)))
-> Maybe (RealTime -> Typed Y)
-> Deriver (Maybe (RealTime -> Typed Y))
forall a b. (a -> b) -> a -> b
$ (RealTime -> Typed Y) -> Maybe (RealTime -> Typed Y)
forall a. a -> Maybe a
Just ((RealTime -> Typed Y) -> Maybe (RealTime -> Typed Y))
-> (RealTime -> Typed Y) -> Maybe (RealTime -> Typed Y)
forall a b. (a -> b) -> a -> b
$ ControlFunction -> Control -> Dynamic -> RealTime -> Typed Y
DeriveT.call_control_function ControlFunction
f Control
control Dynamic
dyn

untyped_control_at :: ScoreT.Control -> RealTime -> Deriver (Maybe Signal.Y)
untyped_control_at :: Control -> RealTime -> Deriver (Maybe Y)
untyped_control_at Control
cont = (Maybe (Typed Y) -> Maybe Y)
-> Deriver (Maybe (Typed Y)) -> Deriver (Maybe Y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Typed Y -> Y) -> Maybe (Typed Y) -> Maybe Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val) (Deriver (Maybe (Typed Y)) -> Deriver (Maybe Y))
-> (RealTime -> Deriver (Maybe (Typed Y)))
-> RealTime
-> Deriver (Maybe Y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> RealTime -> Deriver (Maybe (Typed Y))
control_at Control
cont

-- | Get a ControlValMap at the given time, taking 'state_control_functions'
-- into account.
{-# SCC controls_at #-}
controls_at :: RealTime -> Deriver ScoreT.ControlValMap
controls_at :: RealTime -> Deriver ControlValMap
controls_at RealTime
pos = do
    State
state <- Deriver State Error State
forall st err. Deriver st err st
get
    Marklists
ruler <- Deriver Marklists
Internal.get_ruler
    ControlValMap -> Deriver ControlValMap
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlValMap -> Deriver ControlValMap)
-> ControlValMap -> Deriver ControlValMap
forall a b. (a -> b) -> a -> b
$! RealTime -> Marklists -> Dynamic -> Int -> ControlValMap
state_controls_at RealTime
pos Marklists
ruler (State -> Dynamic
state_dynamic State
state)
        (Threaded -> Int
state_event_serial (State -> Threaded
state_threaded State
state))

{-# SCC state_controls_at #-}
state_controls_at :: RealTime -> Ruler.Marklists
    -- ^ Ruler marklists from the same track as the Dynamic.  Needed by
    -- control functions, via 'DeriveT.dyn_ruler'.
    -> Dynamic -> Int -- ^ 'state_event_serial'
    -> ScoreT.ControlValMap
state_controls_at :: RealTime -> Marklists -> Dynamic -> Int -> ControlValMap
state_controls_at RealTime
pos Marklists
ruler Dynamic
dyn Int
serial =
    (Control -> Paired ControlFunction (Typed Control) -> Y)
-> Map Control (Paired ControlFunction (Typed Control))
-> ControlValMap
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (Dynamic
-> RealTime
-> Control
-> Paired ControlFunction (Typed Control)
-> Y
forall {k} {kind :: k}.
Dynamic
-> RealTime
-> Control
-> Paired ControlFunction (Typed (Signal kind))
-> Y
resolve (Marklists -> Dynamic -> Int -> Dynamic
Internal.convert_dynamic Marklists
ruler Dynamic
dyn Int
serial) RealTime
pos) (Map Control (Paired ControlFunction (Typed Control))
 -> ControlValMap)
-> Map Control (Paired ControlFunction (Typed Control))
-> ControlValMap
forall a b. (a -> b) -> a -> b
$
    ControlFunctionMap
-> Map Control (Typed Control)
-> Map Control (Paired ControlFunction (Typed Control))
forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> Map k (Paired v1 v2)
Maps.paired (Dynamic -> ControlFunctionMap
state_control_functions Dynamic
dyn) (Dynamic -> Map Control (Typed Control)
state_controls Dynamic
dyn)
    where
    resolve :: Dynamic
-> RealTime
-> Control
-> Paired ControlFunction (Typed (Signal kind))
-> Y
resolve Dynamic
cf_dyn RealTime
pos Control
k Paired ControlFunction (Typed (Signal kind))
p = case Paired ControlFunction (Typed (Signal kind))
p of
        Seq.Both ControlFunction
f Typed (Signal kind)
_ -> Control -> ControlFunction -> Y
call Control
k ControlFunction
f
        Seq.First ControlFunction
f -> Control -> ControlFunction -> Y
call Control
k ControlFunction
f
        Seq.Second Typed (Signal kind)
sig -> RealTime -> Signal kind -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
pos (Typed (Signal kind) -> Signal kind
forall a. Typed a -> a
ScoreT.typed_val Typed (Signal kind)
sig)
        where
        call :: Control -> ControlFunction -> Y
call Control
control ControlFunction
f = Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val (Typed Y -> Y) -> Typed Y -> Y
forall a b. (a -> b) -> a -> b
$
            ControlFunction -> Control -> Dynamic -> RealTime -> Typed Y
DeriveT.call_control_function ControlFunction
f Control
control Dynamic
cf_dyn RealTime
pos

-- *** control signal

with_control :: ScoreT.Control -> ScoreT.Typed Signal.Control
    -> Deriver a -> Deriver a
with_control :: forall a. Control -> Typed Control -> Deriver a -> Deriver a
with_control Control
control Typed Control
signal = [(Control, Typed Control)] -> Deriver a -> Deriver a
forall a. [(Control, Typed Control)] -> Deriver a -> Deriver a
with_controls [(Control
control, Typed Control
signal)]

with_constant_control :: ScoreT.Control -> Signal.Y -> Deriver a -> Deriver a
with_constant_control :: forall a. Control -> Y -> Deriver a -> Deriver a
with_constant_control Control
control Y
val =
    Control -> Typed Control -> Deriver a -> Deriver a
forall a. Control -> Typed Control -> Deriver a -> Deriver a
with_control Control
control (Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
val))

with_controls :: [(ScoreT.Control, ScoreT.Typed Signal.Control)]
    -> Deriver a -> Deriver a
with_controls :: forall a. [(Control, Typed Control)] -> Deriver a -> Deriver a
with_controls [(Control, Typed Control)]
controls
    | [(Control, Typed Control)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Control, Typed Control)]
controls = Deriver a -> Deriver a
forall a. a -> a
id
    | Bool
otherwise = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
        { state_controls :: Map Control (Typed Control)
state_controls = [(Control, Typed Control)]
-> Map Control (Typed Control) -> Map Control (Typed Control)
forall k v. Ord k => [(k, v)] -> Map k v -> Map k v
Maps.insertList [(Control, Typed Control)]
controls (Dynamic -> Map Control (Typed Control)
state_controls Dynamic
state)
        }

-- | Remove both controls and control functions.  Use this when a control has
-- already been applied, and you don't want it to affect further derivation.
remove_controls :: [ScoreT.Control] -> Deriver a -> Deriver a
remove_controls :: forall a. [Control] -> Deriver a -> Deriver a
remove_controls [Control]
controls
    | [Control] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Control]
controls = Deriver a -> Deriver a
forall a. a -> a
id
    | Bool
otherwise = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
        { state_controls :: Map Control (Typed Control)
state_controls = [Control]
-> Map Control (Typed Control) -> Map Control (Typed Control)
forall k a. Ord k => [k] -> Map k a -> Map k a
Maps.deleteKeys [Control]
controls (Dynamic -> Map Control (Typed Control)
state_controls Dynamic
state)
        , state_control_functions :: ControlFunctionMap
state_control_functions =
            [Control] -> ControlFunctionMap -> ControlFunctionMap
forall k a. Ord k => [k] -> Map k a -> Map k a
Maps.deleteKeys [Control]
controls (Dynamic -> ControlFunctionMap
state_control_functions Dynamic
state)
        }

with_control_function :: ScoreT.Control -> DeriveT.ControlFunction
    -> Deriver a -> Deriver a
with_control_function :: forall a. Control -> ControlFunction -> Deriver a -> Deriver a
with_control_function Control
control ControlFunction
f = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
    { state_control_functions :: ControlFunctionMap
state_control_functions =
        Control
-> ControlFunction -> ControlFunctionMap -> ControlFunctionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Control
control ControlFunction
f (Dynamic -> ControlFunctionMap
state_control_functions Dynamic
state)
    }

-- | Replace the controls entirely.
with_control_maps :: DeriveT.ControlMap -> DeriveT.ControlFunctionMap
    -> Deriver a -> Deriver a
with_control_maps :: forall a.
Map Control (Typed Control)
-> ControlFunctionMap -> Deriver a -> Deriver a
with_control_maps Map Control (Typed Control)
cmap ControlFunctionMap
cfuncs = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
    { state_controls :: Map Control (Typed Control)
state_controls = Map Control (Typed Control)
cmap
    , state_control_functions :: ControlFunctionMap
state_control_functions = ControlFunctionMap
cfuncs
    }

-- | Modify the given control according to the Merger.
--
-- If both signals are typed, the existing type wins over the relative
-- signal's type.  If one is untyped, the typed one wins.
--
-- As documetned in 'merge', this acts like a Set if there is no existing
-- control.
with_merged_control :: Merger -> ScoreT.Control -> ScoreT.Typed Signal.Control
    -> Deriver a -> Deriver a
with_merged_control :: forall a.
Merger -> Control -> Typed Control -> Deriver a -> Deriver a
with_merged_control Merger
merger Control
control Typed Control
signal Deriver a
deriver = do
    Map Control (Typed Control)
controls <- Deriver State Error (Map Control (Typed Control))
get_controls
    let new :: Typed Control
new = Merger -> Maybe (Typed Control) -> Typed Control -> Typed Control
merge Merger
merger (Control -> Map Control (Typed Control) -> Maybe (Typed Control)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control Map Control (Typed Control)
controls) Typed Control
signal
    Control -> Typed Control -> Deriver a -> Deriver a
forall a. Control -> Typed Control -> Deriver a -> Deriver a
with_control Control
control Typed Control
new Deriver a
deriver

-- | Like 'with_controls', but merge them with their respective default
-- 'Merger's.
with_merged_controls :: [(ScoreT.Control, ScoreT.Typed Signal.Control)]
    -> Deriver a -> Deriver a
with_merged_controls :: forall a. [(Control, Typed Control)] -> Deriver a -> Deriver a
with_merged_controls [(Control, Typed Control)]
control_vals Deriver a
deriver
    | [(Control, Typed Control)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Control, Typed Control)]
control_vals = Deriver a
deriver
    | Bool
otherwise = do
        let ([Control]
controls, [Typed Control]
new_vals) = [(Control, Typed Control)] -> ([Control], [Typed Control])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Control, Typed Control)]
control_vals
        [Merger]
mergers <- (Control -> Deriver State Error Merger)
-> [Control] -> Deriver State Error [Merger]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Control -> Deriver State Error Merger
get_default_merger [Control]
controls
        Map Control (Typed Control)
signals <- Deriver State Error (Map Control (Typed Control))
get_controls
        let old_vals :: [Maybe (Typed Control)]
old_vals = (Control -> Maybe (Typed Control))
-> [Control] -> [Maybe (Typed Control)]
forall a b. (a -> b) -> [a] -> [b]
map ((Control -> Map Control (Typed Control) -> Maybe (Typed Control))
-> Map Control (Typed Control) -> Control -> Maybe (Typed Control)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Control -> Map Control (Typed Control) -> Maybe (Typed Control)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Control (Typed Control)
signals) [Control]
controls
            merged :: [Typed Control]
merged = (Merger -> Maybe (Typed Control) -> Typed Control -> Typed Control)
-> [Merger]
-> [Maybe (Typed Control)]
-> [Typed Control]
-> [Typed Control]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Merger -> Maybe (Typed Control) -> Typed Control -> Typed Control
merge [Merger]
mergers [Maybe (Typed Control)]
old_vals [Typed Control]
new_vals
        [(Control, Typed Control)] -> Deriver a -> Deriver a
forall a. [(Control, Typed Control)] -> Deriver a -> Deriver a
with_controls ([Control] -> [Typed Control] -> [(Control, Typed Control)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Control]
controls [Typed Control]
merged) Deriver a
deriver

resolve_merge :: Merge -> ScoreT.Control -> Deriver Merger
resolve_merge :: Merge -> Control -> Deriver State Error Merger
resolve_merge Merge
DefaultMerge Control
control = Control -> Deriver State Error Merger
get_default_merger Control
control
resolve_merge (Merge Merger
merger) Control
_ = Merger -> Deriver State Error Merger
forall (m :: * -> *) a. Monad m => a -> m a
return Merger
merger

get_control_merge :: Expr.Symbol -> Deriver Merger
get_control_merge :: Symbol -> Deriver State Error Merger
get_control_merge Symbol
name = do
    Map Symbol Merger
mergers <- (State -> Map Symbol Merger)
-> Deriver State Error (Map Symbol Merger)
forall st a err. (st -> a) -> Deriver st err a
gets (Constant -> Map Symbol Merger
state_mergers (Constant -> Map Symbol Merger)
-> (State -> Constant) -> State -> Map Symbol Merger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant)
    Text -> Maybe Merger -> Deriver State Error Merger
forall a. Stack => Text -> Maybe a -> Deriver a
require (Text
"unknown control merger: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Symbol -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Symbol
name)
        (Symbol -> Map Symbol Merger -> Maybe Merger
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
name Map Symbol Merger
mergers)

-- | Get the default merger for this control, or 'merge_mul' if there is none.
get_default_merger :: ScoreT.Control -> Deriver Merger
get_default_merger :: Control -> Deriver State Error Merger
get_default_merger Control
control = do
    Map Control Merger
defaults <- (Dynamic -> Map Control Merger) -> Deriver (Map Control Merger)
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Map Control Merger
state_control_merge_defaults
    Merger -> Deriver State Error Merger
forall (m :: * -> *) a. Monad m => a -> m a
return (Merger -> Deriver State Error Merger)
-> Merger -> Deriver State Error Merger
forall a b. (a -> b) -> a -> b
$ Merger -> Control -> Map Control Merger -> Merger
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Merger
default_merge Control
control Map Control Merger
defaults
    where
    default_merge :: Merger
default_merge = Merger
merge_mul

-- | Combine two signals with a Merger.  If there was no old signal, use
-- merger-defined identity value.
--
-- Since the default merge for control tracks is multiplication, whose identity
-- is 1, this means the first control track will set the value, instead of
-- being multiplied to 0.
merge :: Merger -> Maybe (ScoreT.Typed Signal.Control)
    -> ScoreT.Typed Signal.Control -> ScoreT.Typed Signal.Control
merge :: Merger -> Maybe (Typed Control) -> Typed Control -> Typed Control
merge Merger
Set Maybe (Typed Control)
_ Typed Control
new = Typed Control
new
merge Merger
Unset (Just Typed Control
old) Typed Control
_ = Typed Control
old
merge Merger
Unset Maybe (Typed Control)
Nothing Typed Control
new = Typed Control
new
merge (Merger Text
_ Control -> Control -> Control
merger Y
ident) Maybe (Typed Control)
maybe_old Typed Control
new =
    Type -> Control -> Typed Control
forall a. Type -> a -> Typed a
ScoreT.Typed (Typed Control -> Type
forall a. Typed a -> Type
ScoreT.type_of Typed Control
old Type -> Type -> Type
forall a. Semigroup a => a -> a -> a
<> Typed Control -> Type
forall a. Typed a -> Type
ScoreT.type_of Typed Control
new)
        (Control -> Control -> Control
merger (Typed Control -> Control
forall a. Typed a -> a
ScoreT.typed_val Typed Control
old) (Typed Control -> Control
forall a. Typed a -> a
ScoreT.typed_val Typed Control
new))
    where old :: Typed Control
old = Typed Control -> Maybe (Typed Control) -> Typed Control
forall a. a -> Maybe a -> a
fromMaybe (Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
ident)) Maybe (Typed Control)
maybe_old
    -- Using ident is *not* the same as just emitting the 'new' signal for
    -- subtraction!

-- *** ControlMod

-- | Emit a 'ControlMod'.
modify_control :: Merger -> ScoreT.Control -> Signal.Control -> Deriver ()
modify_control :: Merger -> Control -> Control -> Deriver State Error ()
modify_control Merger
merger Control
control Control
signal = (Collect -> Collect) -> Deriver State Error ()
Internal.modify_collect ((Collect -> Collect) -> Deriver State Error ())
-> (Collect -> Collect) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ \Collect
collect ->
    Collect
collect { collect_control_mods :: [ControlMod]
collect_control_mods =
        Control -> Control -> Merger -> ControlMod
ControlMod Control
control Control
signal Merger
merger ControlMod -> [ControlMod] -> [ControlMod]
forall a. a -> [a] -> [a]
: Collect -> [ControlMod]
collect_control_mods Collect
collect }

-- | Apply the collected control mods to the given deriver and clear them out.
eval_control_mods :: RealTime -- ^ Trim controls to end at this time.
    -- If a ControlMod is local to a slice it should end when the slice ends,
    -- and since it bypasses 'Derive.Control.trim_signal', I have to trim
    -- it explicitly.
    -> Deriver a -> Deriver a
eval_control_mods :: forall a. RealTime -> Deriver a -> Deriver a
eval_control_mods RealTime
end Deriver a
deriver = do
    [ControlMod]
mods <- (State -> [ControlMod]) -> Deriver State Error [ControlMod]
forall st a err. (st -> a) -> Deriver st err a
gets (Collect -> [ControlMod]
collect_control_mods (Collect -> [ControlMod])
-> (State -> Collect) -> State -> [ControlMod]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Collect
state_collect)
    if [ControlMod] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ControlMod]
mods then Deriver a
deriver else do
        -- TODO Wait, is this really legit?
        (Collect -> Collect) -> Deriver State Error ()
Internal.modify_collect ((Collect -> Collect) -> Deriver State Error ())
-> (Collect -> Collect) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ \Collect
collect ->
            Collect
collect { collect_control_mods :: [ControlMod]
collect_control_mods = [] }
        [ControlMod] -> RealTime -> Deriver a -> Deriver a
forall a. [ControlMod] -> RealTime -> Deriver a -> Deriver a
with_control_mods [ControlMod]
mods RealTime
end Deriver a
deriver

with_control_mods :: [ControlMod] -> RealTime -> Deriver a -> Deriver a
with_control_mods :: forall a. [ControlMod] -> RealTime -> Deriver a -> Deriver a
with_control_mods [ControlMod]
mods RealTime
end Deriver a
deriver = ((Deriver a -> Deriver a) -> Deriver a -> Deriver a)
-> Deriver a -> [Deriver a -> Deriver a] -> Deriver a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Deriver a -> Deriver a) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
($) Deriver a
deriver ((ControlMod -> Deriver a -> Deriver a)
-> [ControlMod] -> [Deriver a -> Deriver a]
forall a b. (a -> b) -> [a] -> [b]
map ControlMod -> Deriver a -> Deriver a
forall {a}. ControlMod -> Deriver a -> Deriver a
apply [ControlMod]
mods)
    where
    apply :: ControlMod -> Deriver a -> Deriver a
apply (ControlMod Control
control Control
signal Merger
merger) =
        Merger -> Control -> Typed Control -> Deriver a -> Deriver a
forall a.
Merger -> Control -> Typed Control -> Deriver a -> Deriver a
with_merged_control Merger
merger Control
control (Typed Control -> Deriver a -> Deriver a)
-> Typed Control -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Control -> Typed Control) -> Control -> Typed Control
forall a b. (a -> b) -> a -> b
$
            RealTime -> Control -> Control
forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.clip_after RealTime
end Control
signal
            -- TODO is clip_after necessary?  Document end better, with
            -- a reference to a test which demonstrates the issue.

-- ** pitch

-- | The pitch at the given time.  The transposition controls have not been
-- applied since that is supposed to be done once only when the event is
-- generated.
--
-- The scenario is a call that generates a note based on the current pitch.
-- If 'pitch_at' applied the transposition, the new note would have to remove
-- the transposition signals so they don't get applied again at performance
-- conversion.
pitch_at :: RealTime -> Deriver (Maybe PSignal.Pitch)
pitch_at :: RealTime -> Deriver (Maybe Pitch)
pitch_at RealTime
pos = RealTime -> Pitch -> Maybe Pitch
PSignal.at RealTime
pos (Pitch -> Maybe Pitch)
-> Deriver State Error Pitch -> Deriver (Maybe Pitch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error Pitch
get_pitch

-- | Like 'pitch_at', this is a raw pitch.
named_pitch_at :: ScoreT.PControl -> RealTime -> Deriver (Maybe PSignal.Pitch)
named_pitch_at :: PControl -> RealTime -> Deriver (Maybe Pitch)
named_pitch_at PControl
name RealTime
pos = do
    Maybe Pitch
psig <- PControl -> Deriver (Maybe Pitch)
get_named_pitch PControl
name
    Maybe Pitch -> Deriver (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pitch -> Deriver (Maybe Pitch))
-> Maybe Pitch -> Deriver (Maybe Pitch)
forall a b. (a -> b) -> a -> b
$ RealTime -> Pitch -> Maybe Pitch
PSignal.at RealTime
pos (Pitch -> Maybe Pitch) -> Maybe Pitch -> Maybe Pitch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Pitch
psig

-- | Resolve the raw pitch returned from 'pitch_at' to the final transposed
-- pitch.
resolve_pitch :: RealTime -> PSignal.Pitch -> Deriver PSignal.Transposed
resolve_pitch :: RealTime -> Pitch -> Deriver Transposed
resolve_pitch RealTime
pos Pitch
pitch = do
    ControlValMap
controls <- RealTime -> Deriver ControlValMap
controls_at RealTime
pos
    Transposed -> Deriver Transposed
forall (m :: * -> *) a. Monad m => a -> m a
return (Transposed -> Deriver Transposed)
-> Transposed -> Deriver Transposed
forall a b. (a -> b) -> a -> b
$ ControlValMap -> Pitch -> Transposed
PSignal.apply ControlValMap
controls Pitch
pitch

-- | Unlike 'pitch_at', the transposition has already been applied, because you
-- can't transpose any further once you have a NoteNumber.
nn_at :: RealTime -> Deriver (Maybe Pitch.NoteNumber)
nn_at :: RealTime -> Deriver (Maybe NoteNumber)
nn_at RealTime
pos = Deriver (Maybe Pitch)
-> (Pitch -> Deriver (Maybe NoteNumber))
-> Deriver (Maybe NoteNumber)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (RealTime -> Deriver (Maybe Pitch)
pitch_at RealTime
pos) ((Pitch -> Deriver (Maybe NoteNumber))
 -> Deriver (Maybe NoteNumber))
-> (Pitch -> Deriver (Maybe NoteNumber))
-> Deriver (Maybe NoteNumber)
forall a b. (a -> b) -> a -> b
$ \Pitch
pitch ->
    Text -> Transposed -> Deriver (Maybe NoteNumber)
logged_pitch_nn (Text
"nn " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
pos) (Transposed -> Deriver (Maybe NoteNumber))
-> Deriver Transposed -> Deriver (Maybe NoteNumber)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Pitch -> Deriver Transposed
resolve_pitch RealTime
pos Pitch
pitch

get_pitch :: Deriver PSignal.PSignal
get_pitch :: Deriver State Error Pitch
get_pitch = (Dynamic -> Pitch) -> Deriver State Error Pitch
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Pitch
state_pitch

get_named_pitch :: ScoreT.PControl -> Deriver (Maybe PSignal.PSignal)
get_named_pitch :: PControl -> Deriver (Maybe Pitch)
get_named_pitch = PControl -> Deriver (Maybe Pitch)
Internal.get_named_pitch

named_nn_at :: ScoreT.PControl -> RealTime -> Deriver (Maybe Pitch.NoteNumber)
named_nn_at :: PControl -> RealTime -> Deriver (Maybe NoteNumber)
named_nn_at PControl
name RealTime
pos = do
    ControlValMap
controls <- RealTime -> Deriver ControlValMap
controls_at RealTime
pos
    Deriver (Maybe Pitch)
-> (Pitch -> Deriver (Maybe NoteNumber))
-> Deriver (Maybe NoteNumber)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (PControl -> RealTime -> Deriver (Maybe Pitch)
named_pitch_at PControl
name RealTime
pos) ((Pitch -> Deriver (Maybe NoteNumber))
 -> Deriver (Maybe NoteNumber))
-> (Pitch -> Deriver (Maybe NoteNumber))
-> Deriver (Maybe NoteNumber)
forall a b. (a -> b) -> a -> b
$ \Pitch
pitch ->
        Text -> Transposed -> Deriver (Maybe NoteNumber)
logged_pitch_nn (Text
"named_nn " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (PControl, RealTime) -> Text
forall a. Pretty a => a -> Text
pretty (PControl
name, RealTime
pos)) (Transposed -> Deriver (Maybe NoteNumber))
-> Transposed -> Deriver (Maybe NoteNumber)
forall a b. (a -> b) -> a -> b
$
            ControlValMap -> Pitch -> Transposed
PSignal.apply ControlValMap
controls Pitch
pitch

-- | Version of 'PSignal.pitch_nn' that logs errors.
logged_pitch_nn :: Text -> PSignal.Transposed
    -> Deriver (Maybe Pitch.NoteNumber)
logged_pitch_nn :: Text -> Transposed -> Deriver (Maybe NoteNumber)
logged_pitch_nn Text
msg Transposed
pitch = case Transposed -> Either PitchError NoteNumber
PSignal.pitch_nn Transposed
pitch of
    Left PitchError
err -> do
        Text -> Deriver State Error ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> Deriver State Error ()) -> Text -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Text
"pitch_nn " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PitchError -> Text
forall a. Pretty a => a -> Text
pretty PitchError
err
        Maybe NoteNumber -> Deriver (Maybe NoteNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NoteNumber
forall a. Maybe a
Nothing
    Right NoteNumber
nn -> Maybe NoteNumber -> Deriver (Maybe NoteNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NoteNumber -> Deriver (Maybe NoteNumber))
-> Maybe NoteNumber -> Deriver (Maybe NoteNumber)
forall a b. (a -> b) -> a -> b
$ NoteNumber -> Maybe NoteNumber
forall a. a -> Maybe a
Just NoteNumber
nn

-- *** with signal

with_pitch :: PSignal.PSignal -> Deriver a -> Deriver a
with_pitch :: forall a. Pitch -> Deriver a -> Deriver a
with_pitch = PControl -> (Maybe Pitch -> Pitch) -> Deriver a -> Deriver a
forall a.
PControl -> (Maybe Pitch -> Pitch) -> Deriver a -> Deriver a
modify_pitch PControl
ScoreT.default_pitch ((Maybe Pitch -> Pitch) -> Deriver a -> Deriver a)
-> (Pitch -> Maybe Pitch -> Pitch)
-> Pitch
-> Deriver a
-> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Maybe Pitch -> Pitch
forall a b. a -> b -> a
const

with_named_pitch :: ScoreT.PControl -> PSignal.PSignal -> Deriver a -> Deriver a
with_named_pitch :: forall a. PControl -> Pitch -> Deriver a -> Deriver a
with_named_pitch PControl
pcontrol = PControl -> (Maybe Pitch -> Pitch) -> Deriver a -> Deriver a
forall a.
PControl -> (Maybe Pitch -> Pitch) -> Deriver a -> Deriver a
modify_pitch PControl
pcontrol ((Maybe Pitch -> Pitch) -> Deriver a -> Deriver a)
-> (Pitch -> Maybe Pitch -> Pitch)
-> Pitch
-> Deriver a
-> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Maybe Pitch -> Pitch
forall a b. a -> b -> a
const

with_constant_pitch :: PSignal.Pitch -> Deriver a -> Deriver a
with_constant_pitch :: forall a. Pitch -> Deriver a -> Deriver a
with_constant_pitch = Pitch -> Deriver a -> Deriver a
forall a. Pitch -> Deriver a -> Deriver a
with_pitch (Pitch -> Deriver a -> Deriver a)
-> (Pitch -> Pitch) -> Pitch -> Deriver a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Pitch
PSignal.constant

remove_pitch :: Deriver a -> Deriver a
remove_pitch :: forall a. Deriver a -> Deriver a
remove_pitch = PControl -> (Maybe Pitch -> Pitch) -> Deriver a -> Deriver a
forall a.
PControl -> (Maybe Pitch -> Pitch) -> Deriver a -> Deriver a
modify_pitch PControl
ScoreT.default_pitch (Pitch -> Maybe Pitch -> Pitch
forall a b. a -> b -> a
const Pitch
forall a. Monoid a => a
mempty)

modify_pitch :: ScoreT.PControl -> (Maybe PSignal.PSignal -> PSignal.PSignal)
    -> Deriver a -> Deriver a
modify_pitch :: forall a.
PControl -> (Maybe Pitch -> Pitch) -> Deriver a -> Deriver a
modify_pitch PControl
pcontrol Maybe Pitch -> Pitch
f
    | PControl
pcontrol PControl -> PControl -> Bool
forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state ->
        Dynamic
state { state_pitch :: Pitch
state_pitch = Maybe Pitch -> Pitch
f (Pitch -> Maybe Pitch
forall a. a -> Maybe a
Just (Dynamic -> Pitch
state_pitch Dynamic
state)) }
    | Bool
otherwise = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
        { state_pitches :: PitchMap
state_pitches = (Maybe Pitch -> Maybe Pitch) -> PControl -> PitchMap -> PitchMap
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Pitch -> Maybe Pitch
forall a. a -> Maybe a
Just (Pitch -> Maybe Pitch)
-> (Maybe Pitch -> Pitch) -> Maybe Pitch -> Maybe Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Pitch -> Pitch
f) PControl
pcontrol (Dynamic -> PitchMap
state_pitches Dynamic
state) }

-- * run monad

-- | Embed a LogId into Deriver.  This is for computations that need logging
-- but not a full Deriver.
run_logs :: Log.LogId a -> Deriver a
run_logs :: forall a. LogId a -> Deriver a
run_logs LogId a
action = do
    let (a
val, [Msg]
logs) = LogId a -> (a, [Msg])
forall a. LogId a -> (a, [Msg])
Log.run_id LogId a
action
    (Msg -> Deriver State Error ()) -> [Msg] -> Deriver State Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Msg -> Deriver State Error ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

run_try :: (State -> State) -> Deriver a -> Deriver (Either Error a, State)
run_try :: forall a.
(State -> State) -> Deriver a -> Deriver (Either Error a, State)
run_try State -> State
with_state Deriver a
deriver = do
    State
state <- Deriver State Error State
forall st err. Deriver st err st
get
    let (Either Error a
val, State
state2, [Msg]
logs) = State -> Deriver a -> (Either Error a, State, [Msg])
forall st err a. st -> Deriver st err a -> RunResult st err a
run (State -> State
with_state State
state) Deriver a
deriver
    (Msg -> Deriver State Error ()) -> [Msg] -> Deriver State Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Msg -> Deriver State Error ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    (Either Error a, State) -> Deriver (Either Error a, State)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error a
val, State
state2)

-- * 'Mode'

get_mode :: Deriver Mode
get_mode :: Deriver Mode
get_mode = (State -> Mode) -> Deriver Mode
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Mode
state_mode (Dynamic -> Mode) -> (State -> Dynamic) -> State -> Mode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)

is_lilypond_mode :: Deriver Bool
is_lilypond_mode :: Deriver Bool
is_lilypond_mode = Maybe Config -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe Config -> Bool)
-> Deriver State Error (Maybe Config) -> Deriver Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error (Maybe Config)
lookup_lilypond_config

lookup_lilypond_config :: Deriver (Maybe Lilypond.Types.Config)
lookup_lilypond_config :: Deriver State Error (Maybe Config)
lookup_lilypond_config = Deriver Mode
get_mode Deriver Mode
-> (Mode -> Deriver State Error (Maybe Config))
-> Deriver State Error (Maybe Config)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Mode
mode -> Maybe Config -> Deriver State Error (Maybe Config)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Config -> Deriver State Error (Maybe Config))
-> Maybe Config -> Deriver State Error (Maybe Config)
forall a b. (a -> b) -> a -> b
$ case Mode
mode of
    Lilypond Config
config -> Config -> Maybe Config
forall a. a -> Maybe a
Just Config
config
    Mode
_ -> Maybe Config
forall a. Maybe a
Nothing

-- | Get the 'CallDuration' of the given deriver.
get_score_duration :: Deriver a
    -> Deriver (Either Error (CallDuration ScoreTime))
get_score_duration :: forall a.
Deriver a -> Deriver (Either Error (CallDuration ScoreTime))
get_score_duration Deriver a
deriver = do
    (Either Error a
val, State
out) <- (State -> State) -> Deriver a -> Deriver (Either Error a, State)
forall a.
(State -> State) -> Deriver a -> Deriver (Either Error a, State)
run_try State -> State
set_mode Deriver a
deriver
    Either Error (CallDuration ScoreTime)
-> Deriver (Either Error (CallDuration ScoreTime))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (CallDuration ScoreTime)
 -> Deriver (Either Error (CallDuration ScoreTime)))
-> Either Error (CallDuration ScoreTime)
-> Deriver (Either Error (CallDuration ScoreTime))
forall a b. (a -> b) -> a -> b
$ case Either Error a
val of
        Left Error
err -> Error -> Either Error (CallDuration ScoreTime)
forall a b. a -> Either a b
Left Error
err
        Right a
_ -> CallDuration ScoreTime -> Either Error (CallDuration ScoreTime)
forall a b. b -> Either a b
Right (CallDuration ScoreTime -> Either Error (CallDuration ScoreTime))
-> CallDuration ScoreTime -> Either Error (CallDuration ScoreTime)
forall a b. (a -> b) -> a -> b
$ Collect -> CallDuration ScoreTime
collect_score_duration (Collect -> CallDuration ScoreTime)
-> Collect -> CallDuration ScoreTime
forall a b. (a -> b) -> a -> b
$ State -> Collect
state_collect State
out
    where
    set_mode :: State -> State
set_mode State
state = State
state
        { state_collect :: Collect
state_collect = Collect
forall a. Monoid a => a
mempty
        , state_dynamic :: Dynamic
state_dynamic = (State -> Dynamic
state_dynamic State
state)
            { state_mode :: Mode
state_mode = Mode
ScoreDurationQuery }
        }

get_real_duration :: Deriver a -> Deriver (Either Error (CallDuration RealTime))
get_real_duration :: forall a.
Deriver a -> Deriver (Either Error (CallDuration RealTime))
get_real_duration Deriver a
deriver = do
    (Either Error a
val, State
out) <- (State -> State) -> Deriver a -> Deriver (Either Error a, State)
forall a.
(State -> State) -> Deriver a -> Deriver (Either Error a, State)
run_try State -> State
set_mode Deriver a
deriver
    Either Error (CallDuration RealTime)
-> Deriver (Either Error (CallDuration RealTime))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (CallDuration RealTime)
 -> Deriver (Either Error (CallDuration RealTime)))
-> Either Error (CallDuration RealTime)
-> Deriver (Either Error (CallDuration RealTime))
forall a b. (a -> b) -> a -> b
$ case Either Error a
val of
        Left Error
err -> Error -> Either Error (CallDuration RealTime)
forall a b. a -> Either a b
Left Error
err
        Right a
_ -> CallDuration RealTime -> Either Error (CallDuration RealTime)
forall a b. b -> Either a b
Right (CallDuration RealTime -> Either Error (CallDuration RealTime))
-> CallDuration RealTime -> Either Error (CallDuration RealTime)
forall a b. (a -> b) -> a -> b
$ Collect -> CallDuration RealTime
collect_real_duration (Collect -> CallDuration RealTime)
-> Collect -> CallDuration RealTime
forall a b. (a -> b) -> a -> b
$ State -> Collect
state_collect State
out
    where
    set_mode :: State -> State
set_mode State
state = State
state
        { state_collect :: Collect
state_collect = Collect
forall a. Monoid a => a
mempty
        , state_dynamic :: Dynamic
state_dynamic = (State -> Dynamic
state_dynamic State
state)
            { state_mode :: Mode
state_mode = Mode
RealDurationQuery }
        }

-- * postproc

-- | Replace the 'state_stack' with the one from the event.  This is useful
-- for transformers, so they can show a stack trace to the event they are
-- processing.
with_event_stack :: Score.Event -> Deriver a -> Deriver a
with_event_stack :: forall a. Event -> Deriver a -> Deriver a
with_event_stack Event
event =
    (Deriver a -> Deriver a)
-> ((BlockId, TrackId, (ScoreTime, ScoreTime))
    -> Deriver a -> Deriver a)
-> Maybe (BlockId, TrackId, (ScoreTime, ScoreTime))
-> Deriver a
-> Deriver a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Deriver a -> Deriver a
forall a. a -> a
id (BlockId, TrackId, (ScoreTime, ScoreTime))
-> Deriver a -> Deriver a
forall {a}.
(BlockId, TrackId, (ScoreTime, ScoreTime))
-> Deriver a -> Deriver a
with_stack (Stack -> Maybe (BlockId, TrackId, (ScoreTime, ScoreTime))
Stack.block_track_region_of (Event -> Stack
Score.event_stack Event
event))
    where
    with_stack :: (BlockId, TrackId, (ScoreTime, ScoreTime))
-> Deriver a -> Deriver a
with_stack (BlockId
block_id, TrackId
track_id, (ScoreTime
s, ScoreTime
e)) = BlockId -> Deriver a -> Deriver a
forall a. BlockId -> Deriver a -> Deriver a
Internal.with_stack_block BlockId
block_id
        (Deriver a -> Deriver a)
-> (Deriver a -> Deriver a) -> Deriver a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackId -> Deriver a -> Deriver a
forall a. TrackId -> Deriver a -> Deriver a
Internal.with_stack_track TrackId
track_id (Deriver a -> Deriver a)
-> (Deriver a -> Deriver a) -> Deriver a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Internal.with_stack_region ScoreTime
s ScoreTime
e

-- | A combination of 'catch' and 'with_event_stack'.
with_event :: Score.Event -> Deriver a -> Deriver (Maybe a)
with_event :: forall a. Event -> Deriver a -> Deriver (Maybe a)
with_event Event
event = Bool -> Deriver a -> Deriver (Maybe a)
forall a. Bool -> Deriver a -> Deriver (Maybe a)
catch Bool
False (Deriver a -> Deriver (Maybe a))
-> (Deriver a -> Deriver a) -> Deriver a -> Deriver (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Deriver a -> Deriver a
forall a. Event -> Deriver a -> Deriver a
with_event_stack Event
event

-- | Shift the controls of a deriver.  You're supposed to apply the warp
-- before deriving the controls, but I don't have a good solution for how to
-- do this yet, so I can leave these here for the moment.
shift_controls :: ScoreTime -> Deriver a -> Deriver a
shift_controls :: forall a. ScoreTime -> Deriver a -> Deriver a
shift_controls ScoreTime
shift Deriver a
deriver = do
    RealTime
real <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Internal.real ScoreTime
shift
    (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local
        (\Dynamic
state -> Dynamic
state
            { state_controls :: Map Control (Typed Control)
state_controls = RealTime
-> Map Control (Typed Control) -> Map Control (Typed Control)
forall {k} {f :: * -> *} {k} {kind :: k}.
Functor f =>
RealTime -> Map k (f (Signal kind)) -> Map k (f (Signal kind))
nudge RealTime
real (Dynamic -> Map Control (Typed Control)
state_controls Dynamic
state)
            , state_pitch :: Pitch
state_pitch = RealTime -> Pitch -> Pitch
nudge_pitch RealTime
real (Dynamic -> Pitch
state_pitch Dynamic
state)
            })
        Deriver a
deriver
    where
    nudge :: RealTime -> Map k (f (Signal kind)) -> Map k (f (Signal kind))
nudge RealTime
delay = (f (Signal kind) -> f (Signal kind))
-> Map k (f (Signal kind)) -> Map k (f (Signal kind))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Signal kind -> Signal kind) -> f (Signal kind) -> f (Signal kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> Signal kind -> Signal kind
forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.shift RealTime
delay))
    nudge_pitch :: RealTime -> Pitch -> Pitch
nudge_pitch = RealTime -> Pitch -> Pitch
PSignal.shift

-- * call

-- | Wrap 'make_val_call' with a 'Typecheck.to_val' to automatically convert
-- to a 'DeriveT.Val'.  This is not in "Derive.Deriver.Monad" to avoid
-- a circular import with "Derive.DeriveT".
val_call :: Typecheck.ToVal a => Module.Module -> CallName -> Tags.Tags
    -> Doc.Doc -> WithArgDoc (PassedArgs Tagged -> Deriver a) -> ValCall
val_call :: forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call Module
module_ CallName
name Tags
tags Doc
doc (PassedArgs Tagged -> Deriver a
call, [ArgDoc]
arg_docs) =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
make_val_call Module
module_ CallName
name Tags
tags Doc
doc ((a -> Val) -> Deriver a -> Deriver Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Val
forall a. ToVal a => a -> Val
Typecheck.to_val (Deriver a -> Deriver Val)
-> (PassedArgs Tagged -> Deriver a)
-> PassedArgs Tagged
-> Deriver Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs Tagged -> Deriver a
call, [ArgDoc]
arg_docs)

set_module :: Module.Module -> Call f -> Call f
set_module :: forall f. Module -> Call f -> Call f
set_module Module
module_ Call f
call = Call f
call
    { call_doc :: CallDoc
call_doc = (Call f -> CallDoc
forall func. Call func -> CallDoc
call_doc Call f
call) { cdoc_module :: Module
cdoc_module = Module
module_ } }