-- 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
    , remove_val, remove_vals
    , modify_val
    , with_scale, with_instrument
    , with_instrument_alias, with_instrument_aliases
    , instrument_exists
    , get_instrument, lookup_instrument

    -- ** control
    , lookup_signal
    , lookup_function, get_function
    , is_control_set
    , get_control_map
    , get_function_map
    , control_at, untyped_control_at, controls_at
    , modify_signals

    -- *** control signal
    , with_control, with_constant_control
    , with_controls
    , remove_controls
    , 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
    , named_nn_at
    , lookup_pitch_signal
    , 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.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Maps as Maps

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.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 = forall st err a. st -> Deriver st err a -> RunResult st err a
run (Constant -> Dynamic -> State
initial_state Constant
constant Dynamic
dynamic)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. Environ -> Deriver d -> Deriver d
with_initial_scope (Dynamic -> Environ
state_environ Dynamic
dynamic)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Either Error (Stream a) -> [Msg] -> Stream a
merge_logs Either Error (Stream Event)
result ([Msg]
more_logs forall a. [a] -> [a] -> [a]
++ [Msg]
logs)
    , r_cache :: Cache
r_cache = Collect -> Cache
collect_cache Collect
collect 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 forall a. State -> StateId a -> Either Error (a, State, UiDamage)
Ui.run_id State
ui_state forall (m :: * -> *). M m => m [(BlockId, [Tree TrackId])]
TrackWarp.get_track_trees of
            Left Error
err -> ([Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn forall a. Maybe a
Nothing Text
msg], [])
                where msg :: Text
msg = Text
"error collecting TrackWarps: " forall a. Semigroup a => a -> a -> a
<> 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Paired Dynamic Dynamic -> Dynamic
extract forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
        Lists.First Dynamic
dyn -> Dynamic
dyn
        Lists.Second Dynamic
dyn -> Dynamic
dyn
        Lists.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) forall a. Semigroup a => a -> a -> a
<> Dynamic -> Environ
state_environ Dynamic
normal
        }
    keep :: Environ -> Environ
keep Environ
env = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty ([(Text, Val)] -> Environ
Env.from_list forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Text
EnvKey.scale) 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 = forall a. Deriver a -> Deriver a
set_inst (forall a. Deriver a -> Deriver a
set_scale Deriver d
deriver)
    where
    set_inst :: Deriver d -> Deriver d
set_inst = case forall a. Typecheck a => Text -> Environ -> Either LookupError a
Env.get_val Text
EnvKey.instrument Environ
env of
        Right Instrument
inst -> forall d. Instrument -> Deriver d -> Deriver d
with_instrument Instrument
inst
        Either LookupError Instrument
_ -> forall a. a -> a
id
    set_scale :: Deriver b -> Deriver b
set_scale = case 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)
            forall d. Scale -> Deriver d -> Deriver d
with_scale Scale
scale Deriver b
deriver
        Either LookupError Str
_ -> 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 =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (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 <- 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) = forall st err a. st -> Deriver st err a -> RunResult st err a
run (State
state { state_collect :: Collect
state_collect = forall a. Monoid a => a
mempty }) Deriver a
deriver
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    case Either Error a
result of
        Left Error
err -> do
            forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write forall a b. (a -> b) -> a -> b
$ Error -> Msg
error_to_warn Error
err
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Right a
val -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
collect 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)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
val


-- * state access

get_stack :: Deriver Stack.Stack
get_stack :: Deriver Stack
get_stack = forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Stack
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- 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
&& 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
&& 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
&& 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
&& forall {call}. ScopePriority call -> Bool
empty ScopePriority ValCall
val ->
                forall a. Stack => Text -> Deriver a
throw forall a b. (a -> b) -> a -> b
$ Text
"no calls in the imported module: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Module
module_
        Scopes
extracted -> forall (m :: * -> *) a. Monad m => a -> m a
return Scopes
extracted
    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) = forall {call}. ScopePriority call -> Bool
empty ScopePriority call
a Bool -> Bool -> Bool
&& forall {call}. ScopePriority call -> Bool
empty ScopePriority call
b Bool -> Bool -> Bool
&& forall {call}. ScopePriority call -> Bool
empty ScopePriority call
c
    empty :: ScopePriority call -> Bool
empty (ScopePriority Map CallPriority (CallMap call)
m) = 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 (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Symbol
syms) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Builtins -> Scopes
extract_module Module
module_ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a. (Constant -> a) -> Deriver a
Internal.get_constant Constant -> Builtins
state_builtins
    let missing :: Set Symbol
missing = Set Symbol
syms forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` forall a. Ord a => [a] -> Set a
Set.fromList (Scopes -> [Symbol]
scope_symbols Scopes
scopes)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Bool
Set.null Set Symbol
missing) forall a b. (a -> b) -> a -> b
$
        forall a. Stack => Text -> Deriver a
throw forall a b. (a -> b) -> a -> b
$ Text
"symbols not in module " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Module
module_ forall a. Semigroup a => a -> a -> a
<> Text
": "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a. Set a -> [a]
Set.toList Set Symbol
missing)
    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 = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local 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 = 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 = 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 = 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 = 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 = forall {a}. Map Module (CallMap a) -> ScopePriority a
extract Map Module (CallMap a)
note
        , scope_control :: ScopePriority a
scope_control = forall {a}. Map Module (CallMap a) -> ScopePriority a
extract Map Module (CallMap a)
control
        , scope_pitch :: ScopePriority a
scope_pitch = forall {a}. Map Module (CallMap a) -> ScopePriority a
extract Map Module (CallMap a)
pitch
        }
    extract :: Map Module (CallMap a) -> ScopePriority a
extract = forall a. CallMap a -> ScopePriority a
make forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault 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)
        | forall k a. Map k a -> Bool
Map.null Map Symbol a
calls Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatternCall a]
patterns = forall call. [(CallPriority, CallMap call)] -> ScopePriority call
scope_priority []
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatternCall a]
prio_block = forall call. [(CallPriority, CallMap call)] -> ScopePriority call
scope_priority [(CallPriority
PrioBuiltin, CallMap a
cmap)]
        | Bool
otherwise = 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, forall a. Monoid a => a
mempty { call_patterns :: [PatternCall a]
call_patterns = [PatternCall a]
prio_block })
            ]
        where
        ([PatternCall a]
prio_block, [PatternCall a]
normal) =
            forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition forall {call}. PatternCall call -> Bool
has_prio_block (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 (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 = 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 = 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 = 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 = 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 = forall {call}. ScopePriority call -> ScopePriority call
extract ScopePriority call
note
        , scope_control :: ScopePriority call
scope_control = forall {call}. ScopePriority call -> ScopePriority call
extract ScopePriority call
control
        , scope_pitch :: ScopePriority call
scope_pitch = forall {call}. ScopePriority call -> ScopePriority call
extract ScopePriority call
pitch
        }
    extract :: ScopePriority call -> ScopePriority call
extract = forall {call} {call}.
(CallMap call -> CallMap call)
-> ScopePriority call -> ScopePriority call
map_cmap forall a b. (a -> b) -> a -> b
$ \CallMap call
cmap -> forall a. Monoid a => a
mempty
        { call_map :: Map Symbol call
call_map = forall k a. (k -> Bool) -> Map k a -> Map k a
Maps.filterKey Symbol -> Bool
wanted (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) = forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority forall a b. (a -> b) -> a -> b
$ CallMap call -> CallMap call
f 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) = forall a. Monoid a => [a] -> a
mconcat
    [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, 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, 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, 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) =
        forall {a}. ScopePriority a -> [Symbol]
extract ScopePriority a
note forall a. Semigroup a => a -> a -> a
<> forall {a}. ScopePriority a -> [Symbol]
extract ScopePriority a
control forall a. Semigroup a => a -> a -> a
<> forall {a}. ScopePriority a -> [Symbol]
extract ScopePriority a
pitch
    extract :: ScopePriority a -> [Symbol]
extract (ScopePriority Map CallPriority (CallMap a)
m) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall call. CallMap call -> Map Symbol call
call_map) (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 =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Stack => Text -> Deriver a
throw forall a b. (a -> b) -> a -> b
$ Text
"get_scale: unknown scale: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ScaleId
scale_id) forall (m :: * -> *) a. Monad m => a -> m a
return
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScaleId -> Deriver (Maybe Scale)
lookup_scale ScaleId
scale_id

lookup_scale :: Pitch.ScaleId -> Deriver (Maybe Scale)
lookup_scale :: ScaleId -> Deriver (Maybe Scale)
lookup_scale ScaleId
scale_id = do
    LookupScale Environ -> ScaleId -> Maybe (Either PitchError Scale)
lookup <- forall st a err. (st -> a) -> Deriver st err a
gets (Constant -> LookupScale
state_lookup_scale 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just (Left PitchError
err) -> forall a. Stack => Text -> Deriver a
throw forall a b. (a -> b) -> a -> b
$ Text
"lookup " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ScaleId
scale_id forall a. Semigroup a => a -> a -> a
<> Text
": "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty PitchError
err
        Just (Right Scale
scale) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 =
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Stack => Text -> Deriver a
throw forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typecheck a => Text -> Environ -> Either Text (Maybe a)
Env.checked_val Text
key 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 = forall a. Maybe a -> Bool
Maybe.isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Environ -> Maybe Val
Env.lookup Text
key 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 <- forall a. Typecheck a => Text -> Deriver (Maybe a)
lookup_val Text
key
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Stack => Text -> Deriver a
throw forall a b. (a -> b) -> a -> b
$ Text
"environ val not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
key) 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.

    Remove on VNotGiven, which is what any Nothing will become.  There's no use
    for a VNotGiven in the environ.  The main way this is used is the @val=_@
    c_equal syntax.

    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 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
        forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val_raw Text
EnvKey.scale val
val forall a b. (a -> b) -> a -> b
$ forall d. Scale -> Deriver d -> Deriver d
with_scale Scale
scale Deriver a
deriver
    | Text
key forall a. Eq a => a -> a -> Bool
== Text
EnvKey.instrument, Just Instrument
inst <- forall a. Typecheck a => Val -> Maybe a
Typecheck.from_val_simple Val
v =
        forall d. Instrument -> Deriver d -> Deriver d
with_instrument Instrument
inst Deriver a
deriver
    | Bool
otherwise = do
        Environ
env <- Deriver Environ
Internal.get_environ
        case forall a. ToVal a => Text -> a -> Environ -> Either Text Environ
Env.put_val Text
key Val
v Environ
env of
            Left Text
err -> forall a. Stack => Text -> Deriver a
throw Text
err
            Right Environ
env -> forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local
                (\Dynamic
state -> Dynamic
state { state_environ :: Environ
state_environ = Environ
env }) Deriver a
deriver
    where v :: Val
v = 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
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, val)]
vals = Deriver a
deriver
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
EnvKey.scale, Text
EnvKey.instrument]) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, val)]
vals) =
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val) Deriver a
deriver [(Text, val)]
vals
    | Bool
otherwise = 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 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Stack => Text -> Deriver a
throw forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Text
k, val
v) Either Text Environ
env -> forall a. ToVal a => Text -> a -> Environ -> Either Text Environ
Env.put_val Text
k val
v forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either Text Environ
env)
                (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dynamic -> Environ
state_environ Dynamic
state) [(Text, val)]
vals
        Environ
environ seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. a -> a
id
    | Bool
otherwise = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
        { state_environ :: Environ
state_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.  Also
-- don't check for types, so you can replace a val with one of a different
-- type.  Due to this it's also more efficient.
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 = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
    { state_environ :: Environ
state_environ = forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
key val
val (Dynamic -> Environ
state_environ Dynamic
state) }

with_vals_raw :: Typecheck.ToVal val => [(EnvKey.Key, val)] -> Deriver a
    -> Deriver a
with_vals_raw :: forall val a. ToVal val => [(Text, val)] -> Deriver a -> Deriver a
with_vals_raw [(Text, val)]
vals =
    forall d. Environ -> Deriver d -> Deriver d
with_environ forall a b. (a -> b) -> a -> b
$ [(Text, Val)] -> Environ
Env.from_list (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. ToVal a => a -> Val
Typecheck.to_val) [(Text, val)]
vals)

remove_val :: Env.Key -> Deriver a -> Deriver a
remove_val :: forall a. Text -> Deriver a -> Deriver a
remove_val = forall a. [Text] -> Deriver a -> Deriver a
remove_vals forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])
-- remove_val key = Internal.local $ \state ->
--     state { state_environ = Env.delete key $ state_environ state }

remove_vals :: [Env.Key] -> Deriver a -> Deriver a
remove_vals :: forall a. [Text] -> Deriver a -> Deriver a
remove_vals [Text]
keys = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local forall a b. (a -> b) -> a -> b
$ \Dynamic
state ->
    Dynamic
state { state_environ :: Environ
state_environ = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Environ -> Environ
Env.delete (Dynamic -> Environ
state_environ Dynamic
state) [Text]
keys }

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 = forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
Internal.localm forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> do
    val
val <- Maybe val -> val
modify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall err a. Stack => (err -> Text) -> Either err a -> Deriver a
require_right forall a. a -> a
id (forall a. Typecheck a => Text -> Environ -> Either Text (Maybe a)
Env.checked_val Text
key (Dynamic -> Environ
state_environ Dynamic
state))
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! 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 =
        forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
key (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 = forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
with_scopes (forall {gen} {trans} {track}.
ScopesT gen trans track (ScopePriority ValCall)
-> ScopesT gen trans track (ScopePriority ValCall)
val forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
    where
    pitch :: ScopesT
  (Scope note control (ScopePriority (Generator Pitch)))
  trans
  track
  val
-> ScopesT
     (Scope note control (ScopePriority (Generator Pitch)))
     trans
     track
     val
pitch = forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> gen
s_generatorforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {note} {control} {pitch}. Scope note control pitch :-> pitch
s_pitch forall f a. Lens f a -> (a -> a) -> f -> f
%= forall {call}.
PatternCall call -> ScopePriority call -> ScopePriority call
replace (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 = forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> val
s_val forall f a. Lens f a -> (a -> a) -> f -> f
%= forall {call}.
PatternCall call -> ScopePriority call -> ScopePriority call
replace (forall call. Scale -> (ValCall -> call) -> PatternCall call
scale_to_call Scale
scale forall a. a -> a
id)
    replace :: PatternCall call -> ScopePriority call -> ScopePriority call
replace PatternCall call
pattern =
        forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
replace_priority CallPriority
PrioScale (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 ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ValCall -> call
convert 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 = forall a. Pretty a => a -> Text
pretty (Scale -> ScaleId
scale_id Scale
scale) forall a. Semigroup a => a -> a -> a
<> 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 = forall d. (PassedArgs d -> Deriver (Stream d)) -> GeneratorFunc d
generator_func PassedArgs Pitch -> Deriver State Error (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 = forall a. Taggable a => Context a -> Context Tagged
tag_context (forall val. PassedArgs val -> Context val
passed_ctx PassedArgs a
args) }
    pitch_call :: PassedArgs Pitch -> Deriver State Error (Stream Pitch)
pitch_call PassedArgs Pitch
args = PassedArgs Tagged -> Deriver Val
vcall (forall {a}. Taggable a => PassedArgs a -> PassedArgs Tagged
convert_args PassedArgs Pitch
args) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Val
val -> case Val
val of
        DeriveT.VPitch Pitch
pitch -> forall call. Callable call => Symbol -> Deriver (Maybe call)
lookup_call Symbol
Symbols.default_pitch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (Generator Pitch)
Nothing -> forall val.
PassedArgs val -> Pitch -> Deriver State Error (Stream Pitch)
default_pitch_call PassedArgs Pitch
args Pitch
pitch
            Just Generator Pitch
pcall -> forall d. GeneratorFunc d -> GeneratorF d
gfunc_f (forall func. Call func -> func
call_func Generator Pitch
pcall) 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 = forall func. Call func -> CallName
call_name Generator Pitch
pcall
                , passed_ctx :: Context Pitch
passed_ctx = forall val. PassedArgs val -> Context val
passed_ctx PassedArgs Pitch
args
                }
        Val
_ -> forall a. Stack => Text -> Deriver a
throw forall a b. (a -> b) -> a -> b
$ Text
"scale call " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty CallName
name
            forall a. Semigroup a => a -> a -> a
<> Text
" returned non-pitch: " forall a. Semigroup a => a -> a -> a
<> 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 State Error (Stream Pitch)
default_pitch_call PassedArgs val
args Pitch
pitch = do
    -- This is Args.real, but I can't import it here.
    RealTime
pos <- forall a. Time a => a -> Deriver RealTime
Internal.real forall a b. (a -> b) -> a -> b
$ Event -> ScoreTime
Event.start forall a b. (a -> b) -> a -> b
$ forall val. Context val -> Event
ctx_event forall a b. (a -> b) -> a -> b
$ forall val. PassedArgs val -> Context val
passed_ctx PassedArgs val
args
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Stream a
Stream.from_event 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 = 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val Text
EnvKey.scale) forall a b. (a -> b) -> a -> b
$
            Text -> Environ -> Maybe Val
Env.lookup Text
EnvKey.scale (Instrument -> Environ
inst_environ Instrument
derive_inst)
    forall a. Deriver a -> Deriver a
with_inst forall a b. (a -> b) -> a -> b
$ forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
with_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 -> InstrumentCalls
inst_calls Instrument
derive_inst)) forall a b. (a -> b) -> a -> b
$
        forall a. Deriver a -> Deriver a
with_scale forall a b. (a -> b) -> a -> b
$ 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 = (forall {note} {control} {pitch}. Scope note control pitch :-> note
s_note forall f a. Lens f a -> (a -> a) -> f -> f
%= 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 = (forall {note} {control} {pitch}. Scope note control pitch :-> note
s_note forall f a. Lens f a -> (a -> a) -> f -> f
%= 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 = (forall {note} {control} {pitch}. Scope note control pitch :-> note
s_note forall f a. Lens f a -> (a -> a) -> f -> f
%= 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 = forall {call}.
CallMap call -> ScopePriority call -> ScopePriority call
replace CallMap call
inst_val ScopePriority call
val
            }
    replace :: CallMap call -> ScopePriority call -> ScopePriority call
replace = 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 =
    forall a. Map Instrument Instrument -> Deriver a -> Deriver a
with_instrument_aliases (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
    | 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 = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Instrument Instrument
aliases) 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 = 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 = (forall a b. Either a b -> Bool
Either.isRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd <$>) 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 -> forall a. Stack => Text -> Deriver a
throw forall a b. (a -> b) -> a -> b
$ Text
"instrument "
            forall a. Semigroup a => a -> a -> a
<> Text
"'" forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Instrument
real_inst forall a. Semigroup a => a -> a -> a
<> Text
"': " forall a. Semigroup a => a -> a -> a
<> Text
err
            forall a. Semigroup a => a -> a -> a
<> if Instrument
real_inst forall a. Eq a => a -> a -> Bool
== Instrument
score_inst then Text
""
                else Text
" (aliased from " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Instrument
score_inst forall a. Semigroup a => a -> a -> a
<> Text
")"
        Right Instrument
inst -> 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 <- forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Map Instrument Instrument
state_instrument_aliases
    let real_inst :: Instrument
real_inst = 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 <- forall st a err. (st -> a) -> Deriver st err a
gets forall a b. (a -> b) -> a -> b
$ Constant -> Instrument -> Either Text Instrument
state_lookup_instrument forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant
    forall (m :: * -> *) a. Monad m => a -> m a
return (Instrument
real_inst, Instrument -> Either Text Instrument
lookup_inst Instrument
real_inst)


-- ** control

lookup_signal :: ScoreT.Control -> Deriver (Maybe (ScoreT.Typed Signal.Control))
lookup_signal :: Control -> Deriver (Maybe (Typed Control))
lookup_signal = Control -> Deriver (Maybe (Typed Control))
Typecheck.lookup_signal

lookup_function :: ScoreT.Control -> Deriver (Maybe ScoreT.TypedFunction)
lookup_function :: Control -> Deriver (Maybe TypedFunction)
lookup_function = ControlRef -> Deriver (Maybe TypedFunction)
Typecheck.lookup_function forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall control val. control -> Maybe val -> Ref control val
DeriveT.Ref forall a. Maybe a
Nothing

get_function :: ScoreT.Control -> Deriver ScoreT.TypedFunction
get_function :: Control -> Deriver TypedFunction
get_function = ControlRef -> Deriver TypedFunction
Typecheck.resolve_function forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall control val. control -> Maybe val -> Ref control val
DeriveT.Ref forall a. Maybe a
Nothing

-- | Get the control value at the given time.
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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ RealTime
pos)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Control -> Deriver (Maybe TypedFunction)
lookup_function Control
control

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

is_control_set :: ScoreT.Control -> Deriver Bool
is_control_set :: Control -> Deriver Bool
is_control_set = Text -> Deriver Bool
is_val_set forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Text
ScoreT.control_name

-- *** all signals / functions

-- TODO for notes, to get just signals, no cfs.  Keeping with function / signal
-- naming, should be get_signals and SignalMap?
get_control_map :: Deriver ScoreT.ControlMap
get_control_map :: Deriver ControlMap
get_control_map =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Text, Val) -> Deriver State Error (Maybe (Control, Typed Control))
convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> [(Text, Val)]
Env.to_list forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver Environ
Internal.get_environ
    where
    convert :: (Text, Val) -> Deriver State Error (Maybe (Control, Typed Control))
convert (Text
key, Val
val) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Control
ScoreT.Control Text
key,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Deriver (Maybe (Typed Control))
to_signal Val
val
    to_signal :: Val -> Deriver (Maybe (Typed Control))
to_signal Val
val = case Val -> Maybe (Either (Deriver (Typed Control)) (Typed Control))
Typecheck.val_to_signal Val
val of
        Maybe (Either (Deriver (Typed Control)) (Typed Control))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just (Right Typed Control
sig) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Typed Control
sig
        Just (Left Deriver (Typed Control)
dsig) -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Typed Control)
dsig

-- | Like 'get_function', but get them all.
get_function_map :: Deriver ScoreT.FunctionMap
get_function_map :: Deriver FunctionMap
get_function_map = do
    Dynamic
cf_dyn <- Deriver Dynamic
Internal.get_control_function_dynamic
    let to_function :: Val -> Deriver (Maybe TypedFunction)
to_function Val
val = case Dynamic
-> Val -> Maybe (Either (Deriver TypedFunction) TypedFunction)
Typecheck.val_to_function_dyn Dynamic
cf_dyn Val
val of
            Maybe (Either (Deriver TypedFunction) TypedFunction)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just (Left Deriver TypedFunction
dtf) -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver TypedFunction
dtf
            Just (Right TypedFunction
tf) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just TypedFunction
tf
    let resolve :: (Text, Val) -> Deriver State Error (Maybe (Control, TypedFunction))
resolve (Text
key, Val
val) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Control
ScoreT.Control Text
key,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Deriver (Maybe TypedFunction)
to_function Val
val
    forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Text, Val) -> Deriver State Error (Maybe (Control, TypedFunction))
resolve forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> [(Text, Val)]
Env.to_list forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver Environ
Internal.get_environ)

-- | Get a ControlValMap at the given time.
{-# SCC controls_at #-}
controls_at :: RealTime -> Deriver ScoreT.ControlValMap
controls_at :: RealTime -> Deriver ControlValMap
controls_at = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Typed a -> a
ScoreT.val_of) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Deriver TypedControlValMap
typed_controls_at

typed_controls_at :: RealTime -> Deriver ScoreT.TypedControlValMap
typed_controls_at :: RealTime -> Deriver TypedControlValMap
typed_controls_at RealTime
pos = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ RealTime
pos)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver FunctionMap
get_function_map

-- *** 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 = forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val_raw (Control -> Text
ScoreT.control_name 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 =
    forall a. Control -> Typed Control -> Deriver a -> Deriver a
with_control Control
control (forall a. a -> Typed a
ScoreT.untyped (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 =
    forall val a. ToVal val => [(Text, val)] -> Deriver a -> Deriver a
with_vals_raw (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Control -> Text
ScoreT.control_name) [(Control, Typed Control)]
controls)

-- | 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 = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
    { state_environ :: Environ
state_environ = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Environ -> Environ
Env.delete (Dynamic -> Environ
state_environ Dynamic
state) [Text]
keys }
    where keys :: [Text]
keys = forall a b. (a -> b) -> [a] -> [b]
map Control -> Text
ScoreT.control_name [Control]
controls

-- | 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 documented 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 =
    forall a.
Control
-> (Maybe (Typed Control) -> Typed Control)
-> Deriver a
-> Deriver a
modify_signal Control
control (\Maybe (Typed Control)
mb_sig -> Merger -> Maybe (Typed Control) -> Typed Control -> Typed Control
merge Merger
merger Maybe (Typed Control)
mb_sig Typed Control
signal)

-- | This is not just 'with_control', because I have to merge a control signal
-- into a possible ControlFunction.
modify_signal :: ScoreT.Control
    -> (Maybe ScoreT.TypedSignal -> ScoreT.TypedSignal) -> Deriver a
    -> Deriver a
modify_signal :: forall a.
Control
-> (Maybe (Typed Control) -> Typed Control)
-> Deriver a
-> Deriver a
modify_signal (ScoreT.Control Text
control) Maybe (Typed Control) -> Typed Control
modify = forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
Internal.localm forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> do
    Val
val <- forall err a. Stack => (err -> Text) -> Either err a -> Deriver a
require_right ((Text
control forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) forall a b. (a -> b) -> a -> b
$
        (Maybe (Typed Control) -> Typed Control)
-> Text -> Environ -> Either Text Val
Env.modify_signal Maybe (Typed Control) -> Typed Control
modify Text
control (Dynamic -> Environ
state_environ Dynamic
state)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall val. ToVal val => Text -> val -> Dynamic -> Dynamic
insert_env Text
control Val
val Dynamic
state

-- | 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
    | 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_sigs) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Control, Typed Control)]
control_vals
        [Merger]
mergers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Control -> Deriver Merger
get_default_merger [Control]
controls
        [Maybe (Typed Control)]
old_sigs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Control -> Deriver (Maybe (Typed Control))
lookup_signal [Control]
controls
        let merged :: [Typed Control]
merged = 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_sigs [Typed Control]
new_sigs
        forall a. [(Control, Typed Control)] -> Deriver a -> Deriver a
with_controls (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 Merger
resolve_merge Merge
DefaultMerge Control
control = Control -> Deriver Merger
get_default_merger Control
control
resolve_merge (Merge Merger
merger) Control
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Merger
merger

get_control_merge :: Expr.Symbol -> Deriver Merger
get_control_merge :: Symbol -> Deriver Merger
get_control_merge Symbol
name = do
    Map Symbol Merger
mergers <- forall st a err. (st -> a) -> Deriver st err a
gets (Constant -> Map Symbol Merger
state_mergers forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant)
    forall a. Stack => Text -> Maybe a -> Deriver a
require (Text
"unknown control merger: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Symbol
name)
        (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 Merger
get_default_merger Control
control = do
    Map Control Merger
defaults <- forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Map Control Merger
state_control_merge_defaults
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 =
    forall a. Type -> a -> Typed a
ScoreT.Typed (forall a. Typed a -> Type
ScoreT.type_of Typed Control
old forall a. Semigroup a => a -> a -> a
<> forall a. Typed a -> Type
ScoreT.type_of Typed Control
new)
        (Control -> Control -> Control
merger (forall a. Typed a -> a
ScoreT.val_of Typed Control
old) (forall a. Typed a -> a
ScoreT.val_of Typed Control
new))
    where old :: Typed Control
old = forall a. a -> Maybe a -> a
fromMaybe (forall a. a -> Typed a
ScoreT.untyped (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 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 forall a. a -> [a] -> [a]
: Collect -> [ControlMod]
collect_control_mods Collect
collect }

-- | Modify all VSignal and VPSignal types in environ.
modify_signals :: (Signal.Control -> Signal.Control)
    -> (PSignal.PSignal -> PSignal.PSignal) -> Deriver a -> Deriver a
modify_signals :: forall a.
(Control -> Control) -> (Pitch -> Pitch) -> Deriver a -> Deriver a
modify_signals Control -> Control
modify_control Pitch -> Pitch
modify_pitch = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
    { state_environ :: Environ
state_environ = (Val -> Val) -> Environ -> Environ
Env.map Val -> Val
update (Dynamic -> Environ
state_environ Dynamic
state)
    , state_pitch :: Pitch
state_pitch = Pitch -> Pitch
modify_pitch (Dynamic -> Pitch
state_pitch Dynamic
state)
    }
    where
    update :: Val -> Val
update = \case
        DeriveT.VSignal Typed Control
sig -> Typed Control -> Val
DeriveT.VSignal (Control -> Control
modify_control forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Control
sig)
        DeriveT.VPSignal Pitch
sig -> Pitch -> Val
DeriveT.VPSignal (Pitch -> Pitch
modify_pitch Pitch
sig)
        DeriveT.VCFunction CFunction
cf -> CFunction -> Val
DeriveT.VCFunction forall a b. (a -> b) -> a -> b
$
            CFunction
cf { cf_signal :: Typed Control
DeriveT.cf_signal = Control -> Control
modify_control forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CFunction -> Typed Control
DeriveT.cf_signal CFunction
cf }
        Val
val -> Val
val

-- | 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 <- forall st a err. (st -> a) -> Deriver st err a
gets (Collect -> [ControlMod]
collect_control_mods forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Collect
state_collect)
    if 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 forall a b. (a -> b) -> a -> b
$ \Collect
collect ->
            Collect
collect { collect_control_mods :: [ControlMod]
collect_control_mods = [] }
        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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) Deriver a
deriver (forall a b. (a -> b) -> [a] -> [b]
map 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) =
        forall a.
Merger -> Control -> Typed Control -> Deriver a -> Deriver a
with_merged_control Merger
merger Control
control forall a b. (a -> b) -> a -> b
$ forall a. a -> Typed a
ScoreT.untyped forall a b. (a -> b) -> a -> b
$
            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 = (Pitch -> RealTime -> Maybe Pitch
`PSignal.at` RealTime
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver 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 = (Pitch -> RealTime -> Maybe Pitch
`PSignal.at` RealTime
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PControl -> Deriver Pitch
get_pitch_signal PControl
name

-- | 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
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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) forall a b. (a -> b) -> a -> b
$ \Pitch
pitch ->
    Text -> Transposed -> Deriver (Maybe NoteNumber)
logged_pitch_nn (Text
"nn " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
pos) 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 Pitch
get_pitch = forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Pitch
state_pitch

-- | Re-export 'Typecheck.lookup_pitch_signal', defined there to avoid
-- circular import.
lookup_pitch_signal :: ScoreT.PControl -> Deriver (Maybe PSignal.PSignal)
lookup_pitch_signal :: PControl -> Deriver (Maybe Pitch)
lookup_pitch_signal = PControl -> Deriver (Maybe Pitch)
Typecheck.lookup_pitch_signal

get_pitch_signal :: ScoreT.PControl -> Deriver PSignal.PSignal
get_pitch_signal :: PControl -> Deriver Pitch
get_pitch_signal PControl
pcontrol =
    -- The PControl itself doesn't add the # because that's the ref syntax,
    -- but let's add the # to remind that it's a PControl.
    forall a. Stack => Text -> Maybe a -> Deriver a
require (Text
"no named pitch #" forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val PControl
pcontrol)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PControl -> Deriver (Maybe Pitch)
lookup_pitch_signal PControl
pcontrol

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
    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) forall a b. (a -> b) -> a -> b
$ \Pitch
pitch ->
        Text -> Transposed -> Deriver (Maybe NoteNumber)
logged_pitch_nn (Text
"named_nn " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (PControl
name, RealTime
pos)) 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
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"pitch_nn " forall a. Semigroup a => a -> a -> a
<> Text
msg forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty PitchError
err
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Right NoteNumber
nn -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall a.
PControl -> (Maybe Pitch -> Pitch) -> Deriver a -> Deriver a
modify_pitch PControl
ScoreT.default_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- TODO now that named pitch is just env VPSignals, do I really need this?
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 = forall a.
PControl -> (Maybe Pitch -> Pitch) -> Deriver a -> Deriver a
modify_pitch PControl
pcontrol forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Pitch -> Deriver a -> Deriver a
with_pitch 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 = forall a.
PControl -> (Maybe Pitch -> Pitch) -> Deriver a -> Deriver a
modify_pitch PControl
ScoreT.default_pitch (forall a b. a -> b -> a
const 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
modify Deriver a
deriver
    | PControl
pcontrol forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local
        (\Dynamic
state -> Dynamic
state { state_pitch :: Pitch
state_pitch = Maybe Pitch -> Pitch
modify (forall a. a -> Maybe a
Just (Dynamic -> Pitch
state_pitch Dynamic
state)) })
        Deriver a
deriver
    | Bool
otherwise = do
        Maybe Pitch
mb_sig <- forall a. Typecheck a => Text -> Deriver (Maybe a)
lookup_val (PControl -> Text
ScoreT.pcontrol_name PControl
pcontrol)
        forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
with_val_raw (PControl -> Text
ScoreT.pcontrol_name PControl
pcontrol) (Maybe Pitch -> Pitch
modify Maybe Pitch
mb_sig) Deriver a
deriver

-- * 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) = forall a. LogId a -> (a, [Msg])
Log.run_id LogId a
action
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    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 <- forall st err. Deriver st err st
get
    let (Either Error a
val, State
state2, [Msg]
logs) = forall st err a. st -> Deriver st err a -> RunResult st err a
run (State -> State
with_state State
state) Deriver a
deriver
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    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 = forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Mode
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 = forall a. Maybe a -> Bool
Maybe.isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Maybe Config)
lookup_lilypond_config

lookup_lilypond_config :: Deriver (Maybe Lilypond.Types.Config)
lookup_lilypond_config :: Deriver (Maybe Config)
lookup_lilypond_config = Deriver Mode
get_mode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Mode
mode -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Mode
mode of
    Lilypond Config
config -> forall a. a -> Maybe a
Just Config
config
    Mode
_ -> 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) <- forall a.
(State -> State) -> Deriver a -> Deriver (Either Error a, State)
run_try State -> State
set_mode Deriver a
deriver
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either Error a
val of
        Left Error
err -> forall a b. a -> Either a b
Left Error
err
        Right a
_ -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Collect -> CallDuration ScoreTime
collect_score_duration 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 = 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) <- forall a.
(State -> State) -> Deriver a -> Deriver (Either Error a, State)
run_try State -> State
set_mode Deriver a
deriver
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either Error a
val of
        Left Error
err -> forall a b. a -> Either a b
Left Error
err
        Right a
_ -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Collect -> CallDuration RealTime
collect_real_duration 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 = 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 =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id 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)) = forall a. BlockId -> Deriver a -> Deriver a
Internal.with_stack_block BlockId
block_id
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TrackId -> Deriver a -> Deriver a
Internal.with_stack_track TrackId
track_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Bool -> Deriver a -> Deriver (Maybe a)
catch Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall a. Time a => a -> Deriver RealTime
Internal.real ScoreTime
shift
    forall a.
(Control -> Control) -> (Pitch -> Pitch) -> Deriver a -> Deriver a
modify_signals (forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.shift RealTime
real) (RealTime -> Pitch -> Pitch
PSignal.shift RealTime
real) Deriver a
deriver

-- * 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToVal a => a -> Val
Typecheck.to_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 = (forall func. Call func -> CallDoc
call_doc Call f
call) { cdoc_module :: Module
cdoc_module = Module
module_ } }