-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-} -- for super-classes of Callable
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ConstraintKinds #-}
{- | Implementation for the Deriver monad.

    This module should contain only 'Deriver' and the definitions needed to
    implement it.  Unfortunately that winds up being quite a lot.  Deriver
    carries a 'State', which is depended upon directly by all derivation, so
    it's just as complicated as derivation itself, which is to say, very.

    Since State only really requires data types, the majority of this module
    is data declarations, with the exception of a few constructors which
    are intimately concerned with the type they are constructing.  The library
    of functions to manipulate these types are split into "Derive.Deriver.Lib".

    This module is way too big.  Unfortunately it's hard to split up because
    of circular imports.  Anyone who directly or indirectly needs Deriver
    (e.g. calls) needs to import Derive.  However, anything directly or
    indirectly used by State must be imported by Derive.  Since State is the
    central type that must hold anything that persists beyond the evaluation
    of a single note, that winds up being a lot.  At one point I tried to
    reign in the madness with hs-boot files, but I decided that hs-boot was
    worse.
-}
module Derive.Deriver.Monad (
    -- * Deriver
    Deriver, RunResult
    , modify, get, gets, put, run
    , initialize_log_msg

    -- * error
    , Error(..), ErrorVal(..), CallError(..), TypeErrorT(..), ErrorPlace(..)
    , EvalSource(..)
    , throw, throw_arg_error, throw_error
    , annotate
    , require, require_right

    -- * derived types
    , Callable, callable_name, Tagged(..), Taggable(..)
    , CallableExpr

    , Note, NoteDeriver, NoteArgs
    , Control, ControlDeriver, ControlArgs
    , Pitch, PitchDeriver, PitchArgs

    -- * lookup_call
    , lookup_call

    -- * state
    , State(..), initial_state
    , Threaded(..), initial_threaded
    , Dynamic(..), InstrumentAliases, Inversion(..), initial_dynamic
    , strip_dynamic
    , initial_controls, default_dynamic

    -- ** scope
    , Builtins
    , CallMap(..), single_call
    , Scopes, ScopesT(..)
    , s_generator, s_transformer, s_track, s_val
    , Scope(..), s_note, s_control, s_pitch
    , ScopePriority(..), CallPriority(..)
    , scope_priority, lookup_priority, add_priority, replace_priority
    , DocumentedCall(..)
    , PatternCall(..), pat_call_doc
    , extract_doc, extract_val_doc, extract_track_doc
    -- ** TrackCall
    , TrackCall(..), track_call

    -- ** constant
    , Constant(..), initial_constant
    , Mode(..)
    , mergers, merge_add, merge_sub, merge_mul, merge_scale

    -- ** instrument
    , Instrument(..), InstrumentCalls

    -- ** control
    , Merge(..), Merger(..)

    -- ** collect
    , Collect(..), CacheStats(..), SignalFragments
    , ControlMod(..), Integrated(..)
    , TrackDynamic, CallDuration(..)

    -- * calls
    , Context(..), ctx_track_range, coerce_context
    , dummy_context, tag_context, untag_context
    , Call(..), make_call
    , CallName(..), ArgName(..)
    , sym_to_call_name, str_to_call_name, str_to_arg_name
    , CallDoc(..), ArgDoc(..), ArgParser(..), EnvironDefault(..)
    , WithArgDoc
    , PassedArgs(..)

    -- ** generator
    , Generator, GeneratorFunc(..), GeneratorF, generator_func
    , generator, generator_events, generator1
    , with_score_duration, with_real_duration

    -- ** transformer
    , Transformer, TransformerF
    , transformer

    -- ** val
    , ValCall(..), make_val_call

    -- ** cache types
    -- $cache_doc
    , Cache(..), CacheKey(..), Cached(..), cache_size
    , CacheEntry(..), CallType(..)
    , BlockDeps(..)

    -- ** damage
    , ScoreDamage(..)
    , ControlDamage(..)

    -- * util
    , score_to_real, real_to_score

    -- * scale
    -- $scale_doc
    , Scale(..)
    , LookupScale(..)
    , Transpose, Transposition(..), Enharmonics, Layout

    -- * merge
    , error_to_warn, merge_logs

    -- * testing
    , invalidate_damaged
) where
import qualified Control.DeepSeq as DeepSeq
import           Control.DeepSeq (rnf)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.String as String
import qualified Data.Text as Text
import qualified Data.Vector.Unboxed as Vector.Unboxed

import qualified GHC.Stack

import qualified Util.CallStack as CallStack
import qualified Util.Doc as Doc
import qualified Util.Lens as Lens
import qualified Util.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Pretty as Pretty
import qualified Util.Ranges as Ranges

import qualified Derive.Attrs as Attrs
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.DeriveM as DeriveM
import           Derive.Deriver.DeriveM (get, gets, modify, put, run)
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.PSignal as PSignal
import qualified Derive.ParseTitle as ParseTitle
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.TrackWarp as TrackWarp
import qualified Derive.ValType as ValType
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 Synth.Shared.Note as Shared.Note
import qualified Ui.Event as Event
import qualified Ui.Symbol as Symbol
import qualified Ui.Track as Track
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Ui as Ui

import           Global
import           Types


type Deriver = DeriveM.Deriver State Error
type RunResult a = DeriveM.RunResult State Error a

instance Log.LogMonad Deriver where
    write :: Msg -> Deriver ()
write = Msg -> Deriver ()
forall st err. Msg -> Deriver st err ()
DeriveM.write (Msg -> Deriver ())
-> (Msg -> Deriver State Error Msg) -> Msg -> Deriver ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Msg -> Deriver State Error Msg
initialize_log_msg

initialize_log_msg :: Log.Msg -> Deriver Log.Msg
initialize_log_msg :: Msg -> Deriver State Error Msg
initialize_log_msg Msg
msg = case Msg -> Maybe Stack
Log.msg_stack Msg
msg of
    -- If the msg was created explicitly, it may already have a stack.
    Just Stack
_ -> Msg -> Deriver State Error Msg
forall (m :: * -> *) a. Monad m => a -> m a
return Msg
msg
    Maybe Stack
Nothing -> do
        Stack
stack <- (State -> Stack) -> Deriver State Error Stack
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Stack
state_stack (Dynamic -> Stack) -> (State -> Dynamic) -> State -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
        Msg -> Deriver State Error Msg
forall (m :: * -> *) a. Monad m => a -> m a
return (Msg -> Deriver State Error Msg) -> Msg -> Deriver State Error Msg
forall a b. (a -> b) -> a -> b
$! Msg
msg { msg_stack :: Maybe Stack
Log.msg_stack = Stack -> Maybe Stack
forall a. a -> Maybe a
Just Stack
stack }

-- * error

data Error = Error !GHC.Stack.CallStack !Stack.Stack !ErrorVal
    deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

instance Pretty Error where
    pretty :: Error -> Text
pretty (Error CallStack
call_stack Stack
stack ErrorVal
val) =
        Caller -> Text
CallStack.showCaller (CallStack -> Caller
CallStack.caller CallStack
call_stack)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Stack -> Text
forall a. Pretty a => a -> Text
pretty Stack
stack Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ErrorVal -> Text
forall a. Pretty a => a -> Text
pretty ErrorVal
val

data ErrorVal = GenericError !Text | CallError !CallError
    deriving (Int -> ErrorVal -> ShowS
[ErrorVal] -> ShowS
ErrorVal -> String
(Int -> ErrorVal -> ShowS)
-> (ErrorVal -> String) -> ([ErrorVal] -> ShowS) -> Show ErrorVal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorVal] -> ShowS
$cshowList :: [ErrorVal] -> ShowS
show :: ErrorVal -> String
$cshow :: ErrorVal -> String
showsPrec :: Int -> ErrorVal -> ShowS
$cshowsPrec :: Int -> ErrorVal -> ShowS
Show)

instance Pretty ErrorVal where
    pretty :: ErrorVal -> Text
pretty (GenericError Text
s) = Text
s
    pretty (CallError CallError
err) = CallError -> Text
forall a. Pretty a => a -> Text
pretty CallError
err

data CallError =
    -- | Error typechecking an argument.
    TypeError !TypeErrorT
    -- | Couldn't even call the thing because the name was not found.
    | CallNotFound !Expr.Symbol
    -- | Calling error that doesn't fit into the above categories.
    | ArgError !Text
    deriving (Int -> CallError -> ShowS
[CallError] -> ShowS
CallError -> String
(Int -> CallError -> ShowS)
-> (CallError -> String)
-> ([CallError] -> ShowS)
-> Show CallError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallError] -> ShowS
$cshowList :: [CallError] -> ShowS
show :: CallError -> String
$cshow :: CallError -> String
showsPrec :: Int -> CallError -> ShowS
$cshowsPrec :: Int -> CallError -> ShowS
Show)

data TypeErrorT = TypeErrorT {
    TypeErrorT -> ErrorPlace
error_place :: !ErrorPlace
    , TypeErrorT -> EvalSource
error_source :: !EvalSource
    , TypeErrorT -> ArgName
error_arg_name :: !ArgName
    , TypeErrorT -> Type
error_expected :: !ValType.Type
    , TypeErrorT -> Maybe Val
error_received :: !(Maybe DeriveT.Val)
    -- | 'Typecheck.Eval' or evaluating 'DeriveT.Quoted' may produce a derive
    -- error.
    , TypeErrorT -> Maybe Error
error_derive :: !(Maybe Error)
    } deriving (Int -> TypeErrorT -> ShowS
[TypeErrorT] -> ShowS
TypeErrorT -> String
(Int -> TypeErrorT -> ShowS)
-> (TypeErrorT -> String)
-> ([TypeErrorT] -> ShowS)
-> Show TypeErrorT
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeErrorT] -> ShowS
$cshowList :: [TypeErrorT] -> ShowS
show :: TypeErrorT -> String
$cshow :: TypeErrorT -> String
showsPrec :: Int -> TypeErrorT -> ShowS
$cshowsPrec :: Int -> TypeErrorT -> ShowS
Show)

-- | Where a type error came from.  The arg number starts at 0.
data ErrorPlace = TypeErrorArg !Int | TypeErrorEnviron !EnvKey.Key
    deriving (ErrorPlace -> ErrorPlace -> Bool
(ErrorPlace -> ErrorPlace -> Bool)
-> (ErrorPlace -> ErrorPlace -> Bool) -> Eq ErrorPlace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorPlace -> ErrorPlace -> Bool
$c/= :: ErrorPlace -> ErrorPlace -> Bool
== :: ErrorPlace -> ErrorPlace -> Bool
$c== :: ErrorPlace -> ErrorPlace -> Bool
Eq, Int -> ErrorPlace -> ShowS
[ErrorPlace] -> ShowS
ErrorPlace -> String
(Int -> ErrorPlace -> ShowS)
-> (ErrorPlace -> String)
-> ([ErrorPlace] -> ShowS)
-> Show ErrorPlace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorPlace] -> ShowS
$cshowList :: [ErrorPlace] -> ShowS
show :: ErrorPlace -> String
$cshow :: ErrorPlace -> String
showsPrec :: Int -> ErrorPlace -> ShowS
$cshowsPrec :: Int -> ErrorPlace -> ShowS
Show)

data EvalSource =
    -- | The value in error came from a literal expression.
    Literal
    -- | The value in error came from a 'DeriveT.VQuoted' bit of code.
    | Quoted !DeriveT.Quoted
    -- | The error came from a SubT.Track.  The value is either a track index
    -- into 'ctx_sub_events' or a TrackId from 'ctx_sub_tracks'.
    | SubTrack !(Either Text TrackId)
    deriving (Int -> EvalSource -> ShowS
[EvalSource] -> ShowS
EvalSource -> String
(Int -> EvalSource -> ShowS)
-> (EvalSource -> String)
-> ([EvalSource] -> ShowS)
-> Show EvalSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EvalSource] -> ShowS
$cshowList :: [EvalSource] -> ShowS
show :: EvalSource -> String
$cshow :: EvalSource -> String
showsPrec :: Int -> EvalSource -> ShowS
$cshowsPrec :: Int -> EvalSource -> ShowS
Show)

instance Pretty CallError where
    pretty :: CallError -> Text
pretty = \case
        TypeError TypeErrorT
err -> Text
"TypeError: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeErrorT -> Text
forall a. Pretty a => a -> Text
pretty TypeErrorT
err
        ArgError Text
err -> Text
err
        CallNotFound Symbol
sym -> Text
"CallNotFound: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Symbol -> Text
forall a. Pretty a => a -> Text
pretty Symbol
sym

instance Pretty TypeErrorT where
    pretty :: TypeErrorT -> Text
pretty (TypeErrorT ErrorPlace
place EvalSource
source (ArgName Text
arg_name) Type
expected Maybe Val
mb_received
            Maybe Error
derive_error) = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"arg ", ErrorPlace -> Text
forall a. Pretty a => a -> Text
pretty ErrorPlace
place, Text
"/", Text
arg_name
        , Text
source_desc, Text
": expected ", Type -> Text
forall a. Pretty a => a -> Text
pretty Type
expected
        , case Maybe Val
mb_received of
            Just Val
received -> Text
" but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.type_of Val
received)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Val -> Text
forall a. Pretty a => a -> Text
pretty Val
received
            Maybe Val
Nothing -> Text
" but got no value"
        , Text -> (Error -> Text) -> Maybe Error -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Error -> Text
show_derive_error Maybe Error
derive_error
        ]
        where
        source_desc :: Text
source_desc = case EvalSource
source of
            EvalSource
Literal -> Text
""
            Quoted Quoted
call -> Text
" from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Quoted -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Quoted
call
            SubTrack Either Text TrackId
source -> Text
" from subtrack:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> (TrackId -> Text) -> Either Text TrackId -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id TrackId -> Text
forall a. Show a => a -> Text
showt Either Text TrackId
source
        -- The srcpos and stack of the derive error is probably not
        -- interesting, so I strip those out.
        show_derive_error :: Error -> Text
show_derive_error (Error CallStack
_ Stack
_ ErrorVal
error_val) =
            Text
" (the type conversion required derivation, which crashed: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ErrorVal -> Text
forall a. Pretty a => a -> Text
pretty ErrorVal
error_val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

instance Pretty ErrorPlace where
    pretty :: ErrorPlace -> Text
pretty (TypeErrorArg Int
num) = Int -> Text
forall a. Show a => a -> Text
showt (Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    pretty (TypeErrorEnviron Text
key) = Text
"environ:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
pretty Text
key

throw :: GHC.Stack.HasCallStack => Text -> Deriver a
throw :: forall a. HasCallStack => Text -> Deriver a
throw = ErrorVal -> Deriver a
forall a. HasCallStack => ErrorVal -> Deriver a
throw_error (ErrorVal -> Deriver a) -> (Text -> ErrorVal) -> Text -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ErrorVal
GenericError

throw_arg_error :: GHC.Stack.HasCallStack => Text -> Deriver a
throw_arg_error :: forall a. HasCallStack => Text -> Deriver a
throw_arg_error = ErrorVal -> Deriver a
forall a. HasCallStack => ErrorVal -> Deriver a
throw_error (ErrorVal -> Deriver a) -> (Text -> ErrorVal) -> Text -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallError -> ErrorVal
CallError (CallError -> ErrorVal) -> (Text -> CallError) -> Text -> ErrorVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CallError
ArgError

throw_error :: GHC.Stack.HasCallStack => ErrorVal -> Deriver a
throw_error :: forall a. HasCallStack => ErrorVal -> Deriver a
throw_error ErrorVal
err = do
    Stack
stack <- (State -> Stack) -> Deriver State Error Stack
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Stack
state_stack (Dynamic -> Stack) -> (State -> Dynamic) -> State -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
    Error -> Deriver a
forall err st a. err -> Deriver st err a
DeriveM.throw (CallStack -> Stack -> ErrorVal -> Error
Error CallStack
HasCallStack => CallStack
GHC.Stack.callStack Stack
stack ErrorVal
err)

-- | Catch and rethrow an error, presumably to annotate it with more
-- information.
annotate :: (Error -> Error) -> Deriver a -> Deriver a
annotate :: forall a. (Error -> Error) -> Deriver a -> Deriver a
annotate Error -> Error
f = (Error -> Error) -> Deriver State Error a -> Deriver State Error a
forall err st a.
(err -> err) -> Deriver st err a -> Deriver st err a
DeriveM.annotate Error -> Error
f

require :: GHC.Stack.HasCallStack => Text -> Maybe a -> Deriver a
require :: forall a. HasCallStack => Text -> Maybe a -> Deriver a
require Text
msg = Deriver a -> (a -> Deriver a) -> Maybe a -> Deriver a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Deriver a
forall a. HasCallStack => Text -> Deriver a
throw Text
msg) a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return

require_right :: GHC.Stack.HasCallStack => (err -> Text) -> Either err a
    -> Deriver a
require_right :: forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
require_right err -> Text
fmt_err = (err -> Deriver a) -> (a -> Deriver a) -> Either err a -> Deriver a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Deriver a
forall a. HasCallStack => Text -> Deriver a
throw (Text -> Deriver a) -> (err -> Text) -> err -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
fmt_err) a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return


-- * derived types

-- | Context for Callable on both Generator and Transformer.  It has this name
-- because top-level expression calls have this context.
type CallableExpr d =
    ( Callable (Generator d), Callable (Transformer d), Callable (TrackCall d)
    , Taggable d
    )

{- | Each kind of deriver looks a different scope for its calls.  By making
    this a class method, I can figure out which scope to look in just from the
    type.

    This is essentially a translation from dynamically typed 'ScopesT' and
    'Scopes' to statically typed @Generator Note@ etc.  The class itself should
    be closed, and correspond exactly to the fields of ScopesT * Scopes.
    Surely there is some more direct way to express this, but I haven't figured
    it out yet.  TODO what would this look like in idris?
-}
class Callable call where
    get_builtins_scope :: Builtins -> ModuleMap call
    get_scopes_scope :: Scopes -> ScopePriority call
    -- | What to call this call, for error msgs when lookup fails.
    callable_name :: Proxy call -> Text

instance Callable (Generator Note) where
    get_builtins_scope :: Builtins -> ModuleMap (Generator Event)
get_builtins_scope = Scope
  (ModuleMap (Generator Event))
  (ModuleMap (Generator Control))
  (ModuleMap (Generator PSignal))
-> ModuleMap (Generator Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
   (ModuleMap (Generator Event))
   (ModuleMap (Generator Control))
   (ModuleMap (Generator PSignal))
 -> ModuleMap (Generator Event))
-> (Builtins
    -> Scope
         (ModuleMap (Generator Event))
         (ModuleMap (Generator Control))
         (ModuleMap (Generator PSignal)))
-> Builtins
-> ModuleMap (Generator Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
     (ModuleMap (Generator Event))
     (ModuleMap (Generator Control))
     (ModuleMap (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
    get_scopes_scope :: Scopes -> ScopePriority (Generator Event)
get_scopes_scope = Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator PSignal))
-> ScopePriority (Generator Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
   (ScopePriority (Generator Event))
   (ScopePriority (Generator Control))
   (ScopePriority (Generator PSignal))
 -> ScopePriority (Generator Event))
-> (Scopes
    -> Scope
         (ScopePriority (Generator Event))
         (ScopePriority (Generator Control))
         (ScopePriority (Generator PSignal)))
-> Scopes
-> ScopePriority (Generator Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
     (ScopePriority (Generator Event))
     (ScopePriority (Generator Control))
     (ScopePriority (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
    callable_name :: Proxy (Generator Event) -> Text
callable_name Proxy (Generator Event)
_ = Text
"note generator"
instance Callable (Generator Control) where
    get_builtins_scope :: Builtins -> ModuleMap (Generator Control)
get_builtins_scope = Scope
  (ModuleMap (Generator Event))
  (ModuleMap (Generator Control))
  (ModuleMap (Generator PSignal))
-> ModuleMap (Generator Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
   (ModuleMap (Generator Event))
   (ModuleMap (Generator Control))
   (ModuleMap (Generator PSignal))
 -> ModuleMap (Generator Control))
-> (Builtins
    -> Scope
         (ModuleMap (Generator Event))
         (ModuleMap (Generator Control))
         (ModuleMap (Generator PSignal)))
-> Builtins
-> ModuleMap (Generator Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
     (ModuleMap (Generator Event))
     (ModuleMap (Generator Control))
     (ModuleMap (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
    get_scopes_scope :: Scopes -> ScopePriority (Generator Control)
get_scopes_scope = Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator PSignal))
-> ScopePriority (Generator Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
   (ScopePriority (Generator Event))
   (ScopePriority (Generator Control))
   (ScopePriority (Generator PSignal))
 -> ScopePriority (Generator Control))
-> (Scopes
    -> Scope
         (ScopePriority (Generator Event))
         (ScopePriority (Generator Control))
         (ScopePriority (Generator PSignal)))
-> Scopes
-> ScopePriority (Generator Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
     (ScopePriority (Generator Event))
     (ScopePriority (Generator Control))
     (ScopePriority (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
    callable_name :: Proxy (Generator Control) -> Text
callable_name Proxy (Generator Control)
_ = Text
"control generator"
instance Callable (Generator Pitch) where
    get_builtins_scope :: Builtins -> ModuleMap (Generator PSignal)
get_builtins_scope = Scope
  (ModuleMap (Generator Event))
  (ModuleMap (Generator Control))
  (ModuleMap (Generator PSignal))
-> ModuleMap (Generator PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
   (ModuleMap (Generator Event))
   (ModuleMap (Generator Control))
   (ModuleMap (Generator PSignal))
 -> ModuleMap (Generator PSignal))
-> (Builtins
    -> Scope
         (ModuleMap (Generator Event))
         (ModuleMap (Generator Control))
         (ModuleMap (Generator PSignal)))
-> Builtins
-> ModuleMap (Generator PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
     (ModuleMap (Generator Event))
     (ModuleMap (Generator Control))
     (ModuleMap (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
    get_scopes_scope :: Scopes -> ScopePriority (Generator PSignal)
get_scopes_scope = Scope
  (ScopePriority (Generator Event))
  (ScopePriority (Generator Control))
  (ScopePriority (Generator PSignal))
-> ScopePriority (Generator PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
   (ScopePriority (Generator Event))
   (ScopePriority (Generator Control))
   (ScopePriority (Generator PSignal))
 -> ScopePriority (Generator PSignal))
-> (Scopes
    -> Scope
         (ScopePriority (Generator Event))
         (ScopePriority (Generator Control))
         (ScopePriority (Generator PSignal)))
-> Scopes
-> ScopePriority (Generator PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
     (ScopePriority (Generator Event))
     (ScopePriority (Generator Control))
     (ScopePriority (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
    callable_name :: Proxy (Generator PSignal) -> Text
callable_name Proxy (Generator PSignal)
_ = Text
"pitch generator"

instance Callable (Transformer Note) where
    get_builtins_scope :: Builtins -> ModuleMap (Transformer Event)
get_builtins_scope = Scope
  (ModuleMap (Transformer Event))
  (ModuleMap (Transformer Control))
  (ModuleMap (Transformer PSignal))
-> ModuleMap (Transformer Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
   (ModuleMap (Transformer Event))
   (ModuleMap (Transformer Control))
   (ModuleMap (Transformer PSignal))
 -> ModuleMap (Transformer Event))
-> (Builtins
    -> Scope
         (ModuleMap (Transformer Event))
         (ModuleMap (Transformer Control))
         (ModuleMap (Transformer PSignal)))
-> Builtins
-> ModuleMap (Transformer Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
     (ModuleMap (Transformer Event))
     (ModuleMap (Transformer Control))
     (ModuleMap (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
    get_scopes_scope :: Scopes -> ScopePriority (Transformer Event)
get_scopes_scope = Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer PSignal))
-> ScopePriority (Transformer Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
   (ScopePriority (Transformer Event))
   (ScopePriority (Transformer Control))
   (ScopePriority (Transformer PSignal))
 -> ScopePriority (Transformer Event))
-> (Scopes
    -> Scope
         (ScopePriority (Transformer Event))
         (ScopePriority (Transformer Control))
         (ScopePriority (Transformer PSignal)))
-> Scopes
-> ScopePriority (Transformer Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
     (ScopePriority (Transformer Event))
     (ScopePriority (Transformer Control))
     (ScopePriority (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
    callable_name :: Proxy (Transformer Event) -> Text
callable_name Proxy (Transformer Event)
_ = Text
"note transformer"
instance Callable (Transformer Control) where
    get_builtins_scope :: Builtins -> ModuleMap (Transformer Control)
get_builtins_scope = Scope
  (ModuleMap (Transformer Event))
  (ModuleMap (Transformer Control))
  (ModuleMap (Transformer PSignal))
-> ModuleMap (Transformer Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
   (ModuleMap (Transformer Event))
   (ModuleMap (Transformer Control))
   (ModuleMap (Transformer PSignal))
 -> ModuleMap (Transformer Control))
-> (Builtins
    -> Scope
         (ModuleMap (Transformer Event))
         (ModuleMap (Transformer Control))
         (ModuleMap (Transformer PSignal)))
-> Builtins
-> ModuleMap (Transformer Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
     (ModuleMap (Transformer Event))
     (ModuleMap (Transformer Control))
     (ModuleMap (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
    get_scopes_scope :: Scopes -> ScopePriority (Transformer Control)
get_scopes_scope = Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer PSignal))
-> ScopePriority (Transformer Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
   (ScopePriority (Transformer Event))
   (ScopePriority (Transformer Control))
   (ScopePriority (Transformer PSignal))
 -> ScopePriority (Transformer Control))
-> (Scopes
    -> Scope
         (ScopePriority (Transformer Event))
         (ScopePriority (Transformer Control))
         (ScopePriority (Transformer PSignal)))
-> Scopes
-> ScopePriority (Transformer Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
     (ScopePriority (Transformer Event))
     (ScopePriority (Transformer Control))
     (ScopePriority (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
    callable_name :: Proxy (Transformer Control) -> Text
callable_name Proxy (Transformer Control)
_ = Text
"control transformer"
instance Callable (Transformer Pitch) where
    get_builtins_scope :: Builtins -> ModuleMap (Transformer PSignal)
get_builtins_scope = Scope
  (ModuleMap (Transformer Event))
  (ModuleMap (Transformer Control))
  (ModuleMap (Transformer PSignal))
-> ModuleMap (Transformer PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
   (ModuleMap (Transformer Event))
   (ModuleMap (Transformer Control))
   (ModuleMap (Transformer PSignal))
 -> ModuleMap (Transformer PSignal))
-> (Builtins
    -> Scope
         (ModuleMap (Transformer Event))
         (ModuleMap (Transformer Control))
         (ModuleMap (Transformer PSignal)))
-> Builtins
-> ModuleMap (Transformer PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
     (ModuleMap (Transformer Event))
     (ModuleMap (Transformer Control))
     (ModuleMap (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
    get_scopes_scope :: Scopes -> ScopePriority (Transformer PSignal)
get_scopes_scope = Scope
  (ScopePriority (Transformer Event))
  (ScopePriority (Transformer Control))
  (ScopePriority (Transformer PSignal))
-> ScopePriority (Transformer PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
   (ScopePriority (Transformer Event))
   (ScopePriority (Transformer Control))
   (ScopePriority (Transformer PSignal))
 -> ScopePriority (Transformer PSignal))
-> (Scopes
    -> Scope
         (ScopePriority (Transformer Event))
         (ScopePriority (Transformer Control))
         (ScopePriority (Transformer PSignal)))
-> Scopes
-> ScopePriority (Transformer PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
     (ScopePriority (Transformer Event))
     (ScopePriority (Transformer Control))
     (ScopePriority (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
    callable_name :: Proxy (Transformer PSignal) -> Text
callable_name Proxy (Transformer PSignal)
_ = Text
"pitch transformer"

instance Callable (TrackCall Note) where
    get_builtins_scope :: Builtins -> ModuleMap (TrackCall Event)
get_builtins_scope = Scope
  (ModuleMap (TrackCall Event))
  (ModuleMap (TrackCall Control))
  (ModuleMap (TrackCall PSignal))
-> ModuleMap (TrackCall Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
   (ModuleMap (TrackCall Event))
   (ModuleMap (TrackCall Control))
   (ModuleMap (TrackCall PSignal))
 -> ModuleMap (TrackCall Event))
-> (Builtins
    -> Scope
         (ModuleMap (TrackCall Event))
         (ModuleMap (TrackCall Control))
         (ModuleMap (TrackCall PSignal)))
-> Builtins
-> ModuleMap (TrackCall Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
     (ModuleMap (TrackCall Event))
     (ModuleMap (TrackCall Control))
     (ModuleMap (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
    get_scopes_scope :: Scopes -> ScopePriority (TrackCall Event)
get_scopes_scope = Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall PSignal))
-> ScopePriority (TrackCall Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
   (ScopePriority (TrackCall Event))
   (ScopePriority (TrackCall Control))
   (ScopePriority (TrackCall PSignal))
 -> ScopePriority (TrackCall Event))
-> (Scopes
    -> Scope
         (ScopePriority (TrackCall Event))
         (ScopePriority (TrackCall Control))
         (ScopePriority (TrackCall PSignal)))
-> Scopes
-> ScopePriority (TrackCall Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
     (ScopePriority (TrackCall Event))
     (ScopePriority (TrackCall Control))
     (ScopePriority (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
    callable_name :: Proxy (TrackCall Event) -> Text
callable_name Proxy (TrackCall Event)
_ = Text
"note track call"
instance Callable (TrackCall Control) where
    get_builtins_scope :: Builtins -> ModuleMap (TrackCall Control)
get_builtins_scope = Scope
  (ModuleMap (TrackCall Event))
  (ModuleMap (TrackCall Control))
  (ModuleMap (TrackCall PSignal))
-> ModuleMap (TrackCall Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
   (ModuleMap (TrackCall Event))
   (ModuleMap (TrackCall Control))
   (ModuleMap (TrackCall PSignal))
 -> ModuleMap (TrackCall Control))
-> (Builtins
    -> Scope
         (ModuleMap (TrackCall Event))
         (ModuleMap (TrackCall Control))
         (ModuleMap (TrackCall PSignal)))
-> Builtins
-> ModuleMap (TrackCall Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
     (ModuleMap (TrackCall Event))
     (ModuleMap (TrackCall Control))
     (ModuleMap (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
    get_scopes_scope :: Scopes -> ScopePriority (TrackCall Control)
get_scopes_scope = Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall PSignal))
-> ScopePriority (TrackCall Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
   (ScopePriority (TrackCall Event))
   (ScopePriority (TrackCall Control))
   (ScopePriority (TrackCall PSignal))
 -> ScopePriority (TrackCall Control))
-> (Scopes
    -> Scope
         (ScopePriority (TrackCall Event))
         (ScopePriority (TrackCall Control))
         (ScopePriority (TrackCall PSignal)))
-> Scopes
-> ScopePriority (TrackCall Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
     (ScopePriority (TrackCall Event))
     (ScopePriority (TrackCall Control))
     (ScopePriority (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
    callable_name :: Proxy (TrackCall Control) -> Text
callable_name Proxy (TrackCall Control)
_ = Text
"control track call"
instance Callable (TrackCall Pitch) where
    get_builtins_scope :: Builtins -> ModuleMap (TrackCall PSignal)
get_builtins_scope = Scope
  (ModuleMap (TrackCall Event))
  (ModuleMap (TrackCall Control))
  (ModuleMap (TrackCall PSignal))
-> ModuleMap (TrackCall PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
   (ModuleMap (TrackCall Event))
   (ModuleMap (TrackCall Control))
   (ModuleMap (TrackCall PSignal))
 -> ModuleMap (TrackCall PSignal))
-> (Builtins
    -> Scope
         (ModuleMap (TrackCall Event))
         (ModuleMap (TrackCall Control))
         (ModuleMap (TrackCall PSignal)))
-> Builtins
-> ModuleMap (TrackCall PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
     (ModuleMap (TrackCall Event))
     (ModuleMap (TrackCall Control))
     (ModuleMap (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
    get_scopes_scope :: Scopes -> ScopePriority (TrackCall PSignal)
get_scopes_scope = Scope
  (ScopePriority (TrackCall Event))
  (ScopePriority (TrackCall Control))
  (ScopePriority (TrackCall PSignal))
-> ScopePriority (TrackCall PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
   (ScopePriority (TrackCall Event))
   (ScopePriority (TrackCall Control))
   (ScopePriority (TrackCall PSignal))
 -> ScopePriority (TrackCall PSignal))
-> (Scopes
    -> Scope
         (ScopePriority (TrackCall Event))
         (ScopePriority (TrackCall Control))
         (ScopePriority (TrackCall PSignal)))
-> Scopes
-> ScopePriority (TrackCall PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
     (ScopePriority (TrackCall Event))
     (ScopePriority (TrackCall Control))
     (ScopePriority (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
    callable_name :: Proxy (TrackCall PSignal) -> Text
callable_name Proxy (TrackCall PSignal)
_ = Text
"pitch track call"

instance Callable ValCall where
    get_builtins_scope :: Builtins -> ModuleMap ValCall
get_builtins_scope = Builtins -> ModuleMap ValCall
forall gen trans track val. ScopesT gen trans track val -> val
scopes_val
    get_scopes_scope :: Scopes -> ScopePriority ValCall
get_scopes_scope = Scopes -> ScopePriority ValCall
forall gen trans track val. ScopesT gen trans track val -> val
scopes_val
    callable_name :: Proxy ValCall -> Text
callable_name Proxy ValCall
_ = Text
"val call"

-- | This is for 'ctx_prev_val'.  Normally the previous value is available
-- in all its untagged glory based on the type of the call, but ValCalls can
-- occur with all the different types, so they need a tagged 'ctx_prev_val'.
data Tagged = TagEvent Score.Event | TagControl Signal.Control
    | TagPitch PSignal.PSignal
    deriving (Int -> Tagged -> ShowS
[Tagged] -> ShowS
Tagged -> String
(Int -> Tagged -> ShowS)
-> (Tagged -> String) -> ([Tagged] -> ShowS) -> Show Tagged
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tagged] -> ShowS
$cshowList :: [Tagged] -> ShowS
show :: Tagged -> String
$cshow :: Tagged -> String
showsPrec :: Int -> Tagged -> ShowS
$cshowsPrec :: Int -> Tagged -> ShowS
Show)

instance Pretty Tagged where
    format :: Tagged -> Doc
format (TagEvent Event
a) = Event -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Event
a
    format (TagControl Control
a) = Control -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Control
a
    format (TagPitch PSignal
a) = PSignal -> Doc
forall a. Pretty a => a -> Doc
Pretty.format PSignal
a

class (Show a, Pretty a) => Taggable a where
    to_tagged :: a -> Tagged
    from_tagged :: Tagged -> Maybe a

instance Taggable Tagged where
    to_tagged :: Tagged -> Tagged
to_tagged = Tagged -> Tagged
forall a. a -> a
id
    from_tagged :: Tagged -> Maybe Tagged
from_tagged = Tagged -> Maybe Tagged
forall a. a -> Maybe a
Just

-- ** note

type Note = Score.Event
type NoteDeriver = Deriver (Stream.Stream Score.Event)
type NoteArgs = PassedArgs Score.Event

instance Taggable Note where
    to_tagged :: Event -> Tagged
to_tagged = Event -> Tagged
TagEvent
    from_tagged :: Tagged -> Maybe Event
from_tagged (TagEvent Event
a) = Event -> Maybe Event
forall a. a -> Maybe a
Just Event
a
    from_tagged Tagged
_ = Maybe Event
forall a. Maybe a
Nothing

instance Semigroup NoteDeriver where
    NoteDeriver
d1 <> :: NoteDeriver -> NoteDeriver -> NoteDeriver
<> NoteDeriver
d2 = [NoteDeriver] -> NoteDeriver
d_merge [NoteDeriver
d1, NoteDeriver
d2]
instance Monoid NoteDeriver where
    mempty :: NoteDeriver
mempty = Stream Event -> NoteDeriver
forall (m :: * -> *) a. Monad m => a -> m a
return Stream Event
forall a. Monoid a => a
mempty
    mappend :: NoteDeriver -> NoteDeriver -> NoteDeriver
mappend = NoteDeriver -> NoteDeriver -> NoteDeriver
forall a. Semigroup a => a -> a -> a
(<>)
    mconcat :: [NoteDeriver] -> NoteDeriver
mconcat = [NoteDeriver] -> NoteDeriver
d_merge

-- | This is an invalid instance, because a deriver has no literal syntax.
-- But this lets me put a deriver in a defaulted argument, and get
-- documentation for it.
instance ShowVal.ShowVal NoteDeriver where show_val :: NoteDeriver -> Text
show_val NoteDeriver
_ = Text
"<note-deriver>"
instance ShowVal.ShowVal PitchDeriver where show_val :: PitchDeriver -> Text
show_val PitchDeriver
_ = Text
"<pitch-deriver>"
instance ShowVal.ShowVal ControlDeriver where show_val :: ControlDeriver -> Text
show_val ControlDeriver
_ = Text
"<control-deriver>"

-- ** control

type Control = Signal.Control
type ControlDeriver = Deriver (Stream.Stream Signal.Control)
type ControlArgs = PassedArgs Control

instance Taggable Control where
    to_tagged :: Control -> Tagged
to_tagged = Control -> Tagged
TagControl
    from_tagged :: Tagged -> Maybe Control
from_tagged (TagControl Control
a) = Control -> Maybe Control
forall a. a -> Maybe a
Just Control
a
    from_tagged Tagged
_ = Maybe Control
forall a. Maybe a
Nothing

-- ** pitch

type Pitch = PSignal.PSignal
type PitchDeriver = Deriver (Stream.Stream PSignal.PSignal)
type PitchArgs = PassedArgs Pitch

instance Taggable Pitch where
    to_tagged :: PSignal -> Tagged
to_tagged = PSignal -> Tagged
TagPitch
    from_tagged :: Tagged -> Maybe PSignal
from_tagged (TagPitch PSignal
a) = PSignal -> Maybe PSignal
forall a. a -> Maybe a
Just PSignal
a
    from_tagged Tagged
_ = Maybe PSignal
forall a. Maybe a
Nothing

-- * state

-- | All the state available during derivation.
data State = State {
    -- | Threaded state means deriving one event depends on the results of the
    -- previous event.  This corresponds to StateT.
    State -> Threaded
state_threaded :: !Threaded
    -- | This data is modified in a dynamically scoped way, for
    -- sub-derivations.  This corresponds to ReaderT.
    , State -> Dynamic
state_dynamic :: !Dynamic
    -- | This data is mappended.  It functions like an implicit return value.
    -- This corresponds to WriterT.
    , State -> Collect
state_collect :: !Collect
    -- | This data is constant throughout the derivation.
    , State -> Constant
state_constant :: !Constant
    }

initial_state :: Constant -> Dynamic -> State
initial_state :: Constant -> Dynamic -> State
initial_state Constant
constant Dynamic
dynamic = State
    { state_threaded :: Threaded
state_threaded = Threaded
initial_threaded
    , state_dynamic :: Dynamic
state_dynamic = Dynamic
dynamic
    , state_collect :: Collect
state_collect = Collect
forall a. Monoid a => a
mempty
    , state_constant :: Constant
state_constant = Constant
constant
    }

-- * Threaded

-- | State which is threaded linearly.  This destroys the ability to
-- parallelize derivation, so it's not so great.  However, the only threaded
-- state is state_prev_val, which is only needed within a track, so sibling
-- tracks can still be parallelized.
data Threaded = Threaded {
    -- | Keep track of the previous value for each track currently being
    -- evaluated.  See NOTE [prev-val].
    Threaded -> Map (BlockId, TrackId) Tagged
state_prev_val :: !(Map (BlockId, TrackId) Tagged)
    -- | This is used for 'Stack.Serial' to ensure a unique stack for multiple
    -- generator calls within a single track event.  It's reset on the
    -- evaluation of each uninverted track event, and incremented after
    -- every Score.Event is emitted.  See NOTE [event-serial] for history.
    , Threaded -> Int
state_event_serial :: !Stack.Serial
    } deriving (Int -> Threaded -> ShowS
[Threaded] -> ShowS
Threaded -> String
(Int -> Threaded -> ShowS)
-> (Threaded -> String) -> ([Threaded] -> ShowS) -> Show Threaded
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Threaded] -> ShowS
$cshowList :: [Threaded] -> ShowS
show :: Threaded -> String
$cshow :: Threaded -> String
showsPrec :: Int -> Threaded -> ShowS
$cshowsPrec :: Int -> Threaded -> ShowS
Show)

initial_threaded :: Threaded
initial_threaded :: Threaded
initial_threaded = Map (BlockId, TrackId) Tagged -> Int -> Threaded
Threaded Map (BlockId, TrackId) Tagged
forall a. Monoid a => a
mempty Int
0


-- * Dynamic

-- | This is a dynamically scoped environment that applies to generated events
-- inside its scope.
data Dynamic = Dynamic {
    -- | Derivers can modify it for sub-derivers, or look at it, whether to
    -- attach to an Event or to handle internally.
    Dynamic -> ControlMap
state_controls :: !DeriveT.ControlMap
    -- | Function variant of controls.  Normally they modify a backing
    -- 'Signal.Control', but could be synthesized as well.  See
    -- 'DeriveT.ControlFunction' for details.
    , Dynamic -> ControlFunctionMap
state_control_functions :: !DeriveT.ControlFunctionMap
    , Dynamic -> Map Control Merger
state_control_merge_defaults :: !(Map ScoreT.Control Merger)
    -- | Named pitch signals.
    , Dynamic -> PitchMap
state_pitches :: !DeriveT.PitchMap
    -- | The unnamed pitch signal currently in scope.  This is the pitch signal
    -- that's applied to notes by default.  It's split off from 'state_pitches'
    -- because it's convenient to guarentee that the main pitch signal is
    -- always present.
    , Dynamic -> PSignal
state_pitch :: !PSignal.PSignal
    , Dynamic -> Environ
state_environ :: !DeriveT.Environ
    , Dynamic -> Warp
state_warp :: !Warp.Warp
    -- | Calls currently in scope.
    , Dynamic -> Scopes
state_scopes :: !Scopes
    , Dynamic -> InstrumentAliases
state_instrument_aliases :: !InstrumentAliases
    , Dynamic -> ControlDamage
state_control_damage :: !ControlDamage
    -- | This is a delayed transform.  If a call wants to evaluate under
    -- inversion, it composes itself on to this, which is then applied as
    -- a transformation to the eventual synthesized event at the bottom of the
    -- inversion.
    , Dynamic -> NoteDeriver -> NoteDeriver
state_under_invert :: !(NoteDeriver -> NoteDeriver)
    , Dynamic -> Inversion
state_inversion :: !Inversion
    {- | Each note track sets this to either an unsliced evaluation of the
        closest pitch track below it, or its surrounding 'state_pitch' if there
        is no pitch track below.  Calls can then use it to get neighboring
        pitches.  It's lazily evaluated so there's no extra derivation if you
        don't need it.

        The PSignal is in TrackTime, not RealTime.  This is because the call
        may run in an altered Warp (e.g. integrate runs Internal.in_real_time)
        which would render the PSignal times inaccurate.

        This is cleared when evaluating for itself, so there's no recursion.
        This means given two "next pitch"es in a row, they will both get
        Nothing.  Then on real evaluation, the 2nd will get the next pitch, but
        the 1st will get whatever the 2nd does when it can't get a next pitch.

        TODO if they both emit no pitch, then the 1st will actually get the
        previous pitch, which seems error-prone.  But I think for it to be an
        error, I'd have to have it return an error, e.g. Map TrackTime Pitch
    -}
    , Dynamic -> Maybe (Maybe PSignal, [Msg])
state_pitch_map :: !(Maybe (Maybe PSignal.PSignal, [Log.Msg]))

    -- | This is set to the current note track being evaluated.  It's useful
    -- to look up 'state_prev_val' when evaluating other tracks in an
    -- inversion.  It's set when entering a note track, and unset when entering
    -- a block.
    , Dynamic -> Maybe (BlockId, TrackId)
state_note_track :: !(Maybe (BlockId, TrackId))
    -- | This is the call stack for events.  It's used for error reporting,
    -- and attached to events in case they want to emit errors later (say
    -- during performance).
    , Dynamic -> Stack
state_stack :: !Stack.Stack
    , Dynamic -> Mode
state_mode :: !Mode
    }

-- | Instrument aliases as (alias, destination) pairs.  Map through this before
-- looking in 'state_lookup_instrument'.  The alias destination is always the
-- final instrument, not another alias, so you never have to look up multiple
-- times.
type InstrumentAliases = Map ScoreT.Instrument ScoreT.Instrument

{- | When a note call inverts, it stashes its actual note-generating code so
    it can re-invoke track evaluation on the control tracks below it.  It's
    kind of like saving a continuation.

    Previously I did it by copying the text of the inverting call to the
    generated track.  The problem was that I therefore had to keep the
    evaluated expression around in the call 'Context', and if I forgot to clear
    it in the right places things would be very confusing when a later
    inversion executed unexpected code.  'Derive.Call.Sub.under_invert'
    transforms are now also stored as code rather than data, in
    'state_under_invert'.
-}
data Inversion =
    -- | Pre-inversion.
    NotInverted
    -- | After inversion, but not yet at the bottom.  The inverted generator
    -- is captured here.
    | InversionInProgress !NoteDeriver

instance Pretty Inversion where
    pretty :: Inversion -> Text
pretty Inversion
NotInverted = Text
"NotInverted"
    pretty (InversionInProgress {}) = Text
"InversionInProgress"

initial_dynamic :: DeriveT.Environ -> Dynamic
initial_dynamic :: Environ -> Dynamic
initial_dynamic Environ
environ = Dynamic
    { state_controls :: ControlMap
state_controls = ControlMap
initial_controls
    , state_control_functions :: ControlFunctionMap
state_control_functions = ControlFunctionMap
forall a. Monoid a => a
mempty
    , state_control_merge_defaults :: Map Control Merger
state_control_merge_defaults = Map Control Merger
initial_control_merge_defaults
    , state_pitches :: PitchMap
state_pitches = PitchMap
forall k a. Map k a
Map.empty
    , state_pitch :: PSignal
state_pitch = PSignal
forall a. Monoid a => a
mempty
    , state_environ :: Environ
state_environ = Environ
environ
    , state_warp :: Warp
state_warp = Warp
Warp.identity
    , state_scopes :: Scopes
state_scopes = Scopes
forall a. Monoid a => a
mempty
    , state_instrument_aliases :: InstrumentAliases
state_instrument_aliases = InstrumentAliases
forall a. Monoid a => a
mempty
    , state_control_damage :: ControlDamage
state_control_damage = ControlDamage
forall a. Monoid a => a
mempty
    , state_under_invert :: NoteDeriver -> NoteDeriver
state_under_invert = NoteDeriver -> NoteDeriver
forall a. a -> a
id
    , state_inversion :: Inversion
state_inversion = Inversion
NotInverted
    , state_pitch_map :: Maybe (Maybe PSignal, [Msg])
state_pitch_map = Maybe (Maybe PSignal, [Msg])
forall a. Maybe a
Nothing
    , state_note_track :: Maybe (BlockId, TrackId)
state_note_track = Maybe (BlockId, TrackId)
forall a. Maybe a
Nothing
    , state_stack :: Stack
state_stack = Stack
Stack.empty
    , state_mode :: Mode
state_mode = Mode
Normal
    }

-- | Strip out fields that I don't need to remember in a TrackDynamic.
--
-- If I don't do this, I get a memory leak.  Presumably the cause is that
-- 'state_pitch_map' has an unevaluated pitch derivation, which in turn
-- somehow retains the previous derivation, and then the previous, and so on.
-- This makes each derivation leak more space.
strip_dynamic :: Dynamic -> Dynamic
strip_dynamic :: Dynamic -> Dynamic
strip_dynamic Dynamic
dyn = Dynamic
dyn { state_pitch_map :: Maybe (Maybe PSignal, [Msg])
state_pitch_map = Maybe (Maybe PSignal, [Msg])
forall a. Maybe a
Nothing }
{-# INLINE strip_dynamic #-}

-- | Initial control environment.
initial_controls :: DeriveT.ControlMap
initial_controls :: ControlMap
initial_controls = [(Control, Typed Control)] -> ControlMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Control
Controls.dynamic, Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
default_dynamic))
    ]

initial_control_merge_defaults :: Map ScoreT.Control Merger
initial_control_merge_defaults :: Map Control Merger
initial_control_merge_defaults =
    [(Control, Merger)] -> Map Control Merger
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Control
c, Merger
merge_add) | Control
c <- [Control]
Controls.additive_controls]

-- | A default dynamic that's not 0 is useful because otherwise you have to add
-- dyn to everything.  Since control tracks multiply by default, 1 is the most
-- convenient value.
default_dynamic :: Signal.Y
default_dynamic :: Y
default_dynamic = Y
1

instance Pretty Dynamic where
    format :: Dynamic -> Doc
format (Dynamic ControlMap
controls ControlFunctionMap
cfuncs Map Control Merger
cmerge PitchMap
pitches PSignal
pitch Environ
environ Warp
warp Scopes
scopes
            InstrumentAliases
aliases ControlDamage
control_damage NoteDeriver -> NoteDeriver
_under_invert Inversion
inversion Maybe (Maybe PSignal, [Msg])
pitch_map
            Maybe (BlockId, TrackId)
note_track Stack
stack Mode
mode) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Dynamic"
            [ (Text
"controls", ControlMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ControlMap
controls)
            , (Text
"control_functions", ControlFunctionMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ControlFunctionMap
cfuncs)
            , (Text
"control_merge_defaults", Map Control Merger -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map Control Merger
cmerge)
            , (Text
"pitches", PitchMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format PitchMap
pitches)
            , (Text
"pitch", PSignal -> Doc
forall a. Pretty a => a -> Doc
Pretty.format PSignal
pitch)
            , (Text
"environ", Environ -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Environ
environ)
            , (Text
"warp", Warp -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Warp
warp)
            , (Text
"scopes", Scopes -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Scopes
scopes)
            , (Text
"instrument_aliases", InstrumentAliases -> Doc
forall a. Pretty a => a -> Doc
Pretty.format InstrumentAliases
aliases)
            , (Text
"control_damage", ControlDamage -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ControlDamage
control_damage)
            , (Text
"inversion", Inversion -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Inversion
inversion)
            , (Text
"pitch_map", Maybe (Maybe PSignal, [Msg]) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe (Maybe PSignal, [Msg])
pitch_map)
            , (Text
"note_track", Maybe (BlockId, TrackId) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe (BlockId, TrackId)
note_track)
            , (Text
"stack", Stack -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stack
stack)
            , (Text
"mode", Mode -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Mode
mode)
            ]

instance DeepSeq.NFData Dynamic where
    rnf :: Dynamic -> ()
rnf (Dynamic ControlMap
controls ControlFunctionMap
cfuncs Map Control Merger
cmerge PitchMap
pitches PSignal
pitch Environ
environ Warp
warp Scopes
_scopes
            InstrumentAliases
aliases ControlDamage
control_damage NoteDeriver -> NoteDeriver
_under_invert Inversion
_inversion Maybe (Maybe PSignal, [Msg])
pitch_map
            Maybe (BlockId, TrackId)
note_track Stack
stack Mode
_mode) =
        ControlMap -> ()
forall a. NFData a => a -> ()
rnf ControlMap
controls () -> () -> ()
`seq` ControlFunctionMap -> ()
forall a. NFData a => a -> ()
rnf ControlFunctionMap
cfuncs () -> () -> ()
`seq` Map Control Merger -> ()
forall a. NFData a => a -> ()
rnf Map Control Merger
cmerge () -> () -> ()
`seq` PitchMap -> ()
forall a. NFData a => a -> ()
rnf PitchMap
pitches
        () -> () -> ()
`seq` PSignal -> ()
forall a. NFData a => a -> ()
rnf PSignal
pitch () -> () -> ()
`seq` Environ -> ()
forall a. NFData a => a -> ()
rnf Environ
environ () -> () -> ()
`seq` Warp -> ()
forall a. NFData a => a -> ()
rnf Warp
warp () -> () -> ()
`seq` InstrumentAliases -> ()
forall a. NFData a => a -> ()
rnf InstrumentAliases
aliases
        () -> () -> ()
`seq` ControlDamage -> ()
forall a. NFData a => a -> ()
rnf ControlDamage
control_damage () -> () -> ()
`seq` Maybe (Maybe PSignal, [Msg]) -> ()
forall a. NFData a => a -> ()
rnf Maybe (Maybe PSignal, [Msg])
pitch_map () -> () -> ()
`seq` Maybe (BlockId, TrackId) -> ()
forall a. NFData a => a -> ()
rnf Maybe (BlockId, TrackId)
note_track
        () -> () -> ()
`seq` Stack -> ()
forall a. NFData a => a -> ()
rnf Stack
stack

-- ** scope

-- | This is the library of built-in calls, indexed by Module.  On import, the
-- imported 'CallMap's are inserted into 'Scopes' at 'PrioBuiltin'.
type Builtins = ScopesT
    (MkScopeCallMaps (Generator Note) (Generator Control) (Generator Pitch))
    (MkScopeCallMaps (Transformer Note) (Transformer Control)
        (Transformer Pitch))
    (MkScopeCallMaps (TrackCall Note) (TrackCall Control) (TrackCall Pitch))
    (ModuleMap ValCall)

type MkScopeCallMaps note control pitch = Scope
    (ModuleMap note) (ModuleMap control) (ModuleMap pitch)

type ModuleMap call = Map Module.Module (CallMap call)

-- TODO I can show more than that
instance Show Builtins where show :: Builtins -> String
show Builtins
_ = String
"((Builtins))"

-- | The map takes priority over the patterns.
data CallMap call = CallMap {
    forall call. CallMap call -> Map Symbol call
call_map :: Map Expr.Symbol call
    , forall call. CallMap call -> [PatternCall call]
call_patterns :: [PatternCall call]
    }

single_call :: Expr.Symbol -> call -> CallMap call
single_call :: forall call. Symbol -> call -> CallMap call
single_call Symbol
sym call
call = Map Symbol call -> [PatternCall call] -> CallMap call
forall call. Map Symbol call -> [PatternCall call] -> CallMap call
CallMap (Symbol -> call -> Map Symbol call
forall k a. k -> a -> Map k a
Map.singleton Symbol
sym call
call) []

instance Semigroup (CallMap call) where
    CallMap Map Symbol call
a1 [PatternCall call]
a2 <> :: CallMap call -> CallMap call -> CallMap call
<> CallMap Map Symbol call
b1 [PatternCall call]
b2 = Map Symbol call -> [PatternCall call] -> CallMap call
forall call. Map Symbol call -> [PatternCall call] -> CallMap call
CallMap (Map Symbol call
a1Map Symbol call -> Map Symbol call -> Map Symbol call
forall a. Semigroup a => a -> a -> a
<>Map Symbol call
b1) ([PatternCall call]
a2[PatternCall call] -> [PatternCall call] -> [PatternCall call]
forall a. Semigroup a => a -> a -> a
<>[PatternCall call]
b2)
instance Monoid (CallMap call) where
    mempty :: CallMap call
mempty = Map Symbol call -> [PatternCall call] -> CallMap call
forall call. Map Symbol call -> [PatternCall call] -> CallMap call
CallMap Map Symbol call
forall a. Monoid a => a
mempty [PatternCall call]
forall a. Monoid a => a
mempty
    mappend :: CallMap call -> CallMap call -> CallMap call
mappend = CallMap call -> CallMap call -> CallMap call
forall a. Semigroup a => a -> a -> a
(<>)

instance Pretty (CallMap call) where
    format :: CallMap call -> Doc
format (CallMap Map Symbol call
cmap [PatternCall call]
patterns) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"CallMap"
        [ (Text
"map", [Symbol] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Map Symbol call -> [Symbol]
forall k a. Map k a -> [k]
Map.keys Map Symbol call
cmap))
        , (Text
"patterns", [PatternCall call] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [PatternCall call]
patterns)
        ]

-- | This represents all calls in scope.  Different types of calls are in scope
-- depending on the track type, except ValCalls, which are in scope everywhere.
-- This is dynamic scope, not lexical scope.
--
-- Perhaps this should be called Namespaces, but Id.Namespace is already taken
-- and Scopes is shorter.
type Scopes = ScopesT
    (Scope
        (ScopePriority (Generator Note))
        (ScopePriority (Generator Control))
        (ScopePriority (Generator Pitch)))
    (Scope
        (ScopePriority (Transformer Note))
        (ScopePriority (Transformer Control))
        (ScopePriority (Transformer Pitch)))
    (Scope
        (ScopePriority (TrackCall Note))
        (ScopePriority (TrackCall Control))
        (ScopePriority (TrackCall Pitch)))
    (ScopePriority ValCall)

-- | TODO this could probably now do with a more general name
-- maybe CallType for this, and CallKind for 'Scope'?
-- This is arg type, 'Scope' is return type, or maybe TrackType.
--
-- Calls are in scope by expression position (generator, transformer, track,
-- val) and then by track type (note, control, pitch).  Expression position
-- also determines the the argument type (generator: nothing, transformer:
-- deriver, track: 'TrackTree.EventsTree'), while track type determines the
-- return type (Deriver 'Note', Deriver 'Control', Deriver 'Pitch').
--
-- Val calls are special in that they always have the same type (Args -> Val),
-- and are in scope in val call exrpession position for all track types.
--
-- names: EScope, TScope for ExpressionScope and TrackScope?
-- ExprScope, TrackScope?  I'd want to update the names in CallDoc too.
data ScopesT gen trans track val = Scopes {
    forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator :: !gen
    , forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer :: !trans
    , forall gen trans track val. ScopesT gen trans track val -> track
scopes_track :: !track
    , forall gen trans track val. ScopesT gen trans track val -> val
scopes_val :: !val
    }
    -- Previously, a single Call contained both generator and transformer.
    -- This turned out to not be flexible enough, because an instrument that
    -- wanted to override a generator meant you couldn't use a transformer that
    -- happened to have the same name.  However, there are a number of calls
    -- that want both generator and transformer versions, and it's convenient
    -- to be able to deal with those together.

s_generator :: ScopesT gen trans track val :-> gen
s_generator = (ScopesT gen trans track val -> gen)
-> ((gen -> gen)
    -> ScopesT gen trans track val -> ScopesT gen trans track val)
-> ScopesT gen trans track val :-> gen
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens ScopesT gen trans track val -> gen
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
    (\gen -> gen
f ScopesT gen trans track val
r -> ScopesT gen trans track val
r { scopes_generator :: gen
scopes_generator = gen -> gen
f (ScopesT gen trans track val -> gen
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator ScopesT gen trans track val
r) })
s_transformer :: ScopesT gen trans track val :-> trans
s_transformer = (ScopesT gen trans track val -> trans)
-> ((trans -> trans)
    -> ScopesT gen trans track val -> ScopesT gen trans track val)
-> ScopesT gen trans track val :-> trans
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens ScopesT gen trans track val -> trans
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
    (\trans -> trans
f ScopesT gen trans track val
r -> ScopesT gen trans track val
r { scopes_transformer :: trans
scopes_transformer = trans -> trans
f (ScopesT gen trans track val -> trans
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer ScopesT gen trans track val
r) })
s_track :: ScopesT gen trans track val :-> track
s_track = (ScopesT gen trans track val -> track)
-> ((track -> track)
    -> ScopesT gen trans track val -> ScopesT gen trans track val)
-> ScopesT gen trans track val :-> track
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens ScopesT gen trans track val -> track
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
    (\track -> track
f ScopesT gen trans track val
r -> ScopesT gen trans track val
r { scopes_track :: track
scopes_track = track -> track
f (ScopesT gen trans track val -> track
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track ScopesT gen trans track val
r) })
s_val :: ScopesT gen trans track val :-> val
s_val = (ScopesT gen trans track val -> val)
-> ((val -> val)
    -> ScopesT gen trans track val -> ScopesT gen trans track val)
-> ScopesT gen trans track val :-> val
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens ScopesT gen trans track val -> val
forall gen trans track val. ScopesT gen trans track val -> val
scopes_val
    (\val -> val
f ScopesT gen trans track val
r -> ScopesT gen trans track val
r { scopes_val :: val
scopes_val = val -> val
f (ScopesT gen trans track val -> val
forall gen trans track val. ScopesT gen trans track val -> val
scopes_val ScopesT gen trans track val
r) })

instance (Pretty gen, Pretty trans, Pretty track, Pretty val) =>
        Pretty (ScopesT gen trans track val) where
    format :: ScopesT gen trans track val -> Doc
format (Scopes gen
gen trans
trans track
track val
val) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Scopes"
        [ (Text
"generator", gen -> Doc
forall a. Pretty a => a -> Doc
Pretty.format gen
gen)
        , (Text
"transformer", trans -> Doc
forall a. Pretty a => a -> Doc
Pretty.format trans
trans)
        , (Text
"track", track -> Doc
forall a. Pretty a => a -> Doc
Pretty.format track
track)
        , (Text
"val", val -> Doc
forall a. Pretty a => a -> Doc
Pretty.format val
val)
        ]

instance (Semigroup gen, Semigroup trans, Semigroup track, Semigroup val) =>
        Semigroup (ScopesT gen trans track val) where
    Scopes gen
a1 trans
a2 track
a3 val
a4 <> :: ScopesT gen trans track val
-> ScopesT gen trans track val -> ScopesT gen trans track val
<> Scopes gen
b1 trans
b2 track
b3 val
b4 =
        gen -> trans -> track -> val -> ScopesT gen trans track val
forall gen trans track val.
gen -> trans -> track -> val -> ScopesT gen trans track val
Scopes (gen
a1gen -> gen -> gen
forall a. Semigroup a => a -> a -> a
<>gen
b1) (trans
a2trans -> trans -> trans
forall a. Semigroup a => a -> a -> a
<>trans
b2) (track
a3track -> track -> track
forall a. Semigroup a => a -> a -> a
<>track
b3) (val
a4val -> val -> val
forall a. Semigroup a => a -> a -> a
<>val
b4)
instance (Monoid gen, Monoid trans, Monoid track, Monoid val,
          Semigroup gen, Semigroup trans, Semigroup track, Semigroup val) =>
        Monoid (ScopesT gen trans track val) where
    mempty :: ScopesT gen trans track val
mempty = gen -> trans -> track -> val -> ScopesT gen trans track val
forall gen trans track val.
gen -> trans -> track -> val -> ScopesT gen trans track val
Scopes gen
forall a. Monoid a => a
mempty trans
forall a. Monoid a => a
mempty track
forall a. Monoid a => a
mempty val
forall a. Monoid a => a
mempty
    mappend :: ScopesT gen trans track val
-> ScopesT gen trans track val -> ScopesT gen trans track val
mappend = ScopesT gen trans track val
-> ScopesT gen trans track val -> ScopesT gen trans track val
forall a. Semigroup a => a -> a -> a
(<>)

data Scope note control pitch = Scope {
    forall note control pitch. Scope note control pitch -> note
scope_note :: !note
    , forall note control pitch. Scope note control pitch -> control
scope_control :: !control
    , forall note control pitch. Scope note control pitch -> pitch
scope_pitch :: !pitch
    }

s_note :: Scope note control pitch :-> note
s_note = (Scope note control pitch -> note)
-> ((note -> note)
    -> Scope note control pitch -> Scope note control pitch)
-> Scope note control pitch :-> note
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Scope note control pitch -> note
forall note control pitch. Scope note control pitch -> note
scope_note
    (\note -> note
f Scope note control pitch
r -> Scope note control pitch
r { scope_note :: note
scope_note = note -> note
f (Scope note control pitch -> note
forall note control pitch. Scope note control pitch -> note
scope_note Scope note control pitch
r) })
s_control :: Scope note control pitch :-> control
s_control = (Scope note control pitch -> control)
-> ((control -> control)
    -> Scope note control pitch -> Scope note control pitch)
-> Scope note control pitch :-> control
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Scope note control pitch -> control
forall note control pitch. Scope note control pitch -> control
scope_control
    (\control -> control
f Scope note control pitch
r -> Scope note control pitch
r { scope_control :: control
scope_control = control -> control
f (Scope note control pitch -> control
forall note control pitch. Scope note control pitch -> control
scope_control Scope note control pitch
r) })
s_pitch :: Scope note control pitch :-> pitch
s_pitch = (Scope note control pitch -> pitch)
-> ((pitch -> pitch)
    -> Scope note control pitch -> Scope note control pitch)
-> Scope note control pitch :-> pitch
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Scope note control pitch -> pitch
forall note control pitch. Scope note control pitch -> pitch
scope_pitch
    (\pitch -> pitch
f Scope note control pitch
r -> Scope note control pitch
r { scope_pitch :: pitch
scope_pitch = pitch -> pitch
f (Scope note control pitch -> pitch
forall note control pitch. Scope note control pitch -> pitch
scope_pitch Scope note control pitch
r) })

instance (Pretty note, Pretty control, Pretty pitch) =>
        Pretty (Scope note control pitch) where
    format :: Scope note control pitch -> Doc
format (Scope note
note control
control pitch
pitch) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Scope"
        [ (Text
"note", note -> Doc
forall a. Pretty a => a -> Doc
Pretty.format note
note)
        , (Text
"control", control -> Doc
forall a. Pretty a => a -> Doc
Pretty.format control
control)
        , (Text
"pitch", pitch -> Doc
forall a. Pretty a => a -> Doc
Pretty.format pitch
pitch)
        ]

instance (Semigroup note, Semigroup control, Semigroup pitch) =>
        Semigroup (Scope note control pitch) where
    Scope note
a1 control
a2 pitch
a3 <> :: Scope note control pitch
-> Scope note control pitch -> Scope note control pitch
<> Scope note
b1 control
b2 pitch
b3 =
        note -> control -> pitch -> Scope note control pitch
forall note control pitch.
note -> control -> pitch -> Scope note control pitch
Scope (note
a1note -> note -> note
forall a. Semigroup a => a -> a -> a
<>note
b1) (control
a2control -> control -> control
forall a. Semigroup a => a -> a -> a
<>control
b2) (pitch
a3pitch -> pitch -> pitch
forall a. Semigroup a => a -> a -> a
<>pitch
b3)
instance (Monoid note, Monoid control, Monoid pitch,
          Semigroup note, Semigroup control, Semigroup pitch) =>
        Monoid (Scope note control pitch) where
    mempty :: Scope note control pitch
mempty = note -> control -> pitch -> Scope note control pitch
forall note control pitch.
note -> control -> pitch -> Scope note control pitch
Scope note
forall a. Monoid a => a
mempty control
forall a. Monoid a => a
mempty pitch
forall a. Monoid a => a
mempty
    mappend :: Scope note control pitch
-> Scope note control pitch -> Scope note control pitch
mappend = Scope note control pitch
-> Scope note control pitch -> Scope note control pitch
forall a. Semigroup a => a -> a -> a
(<>)

instance DeepSeq.NFData (Scope a b c) where rnf :: Scope a b c -> ()
rnf Scope a b c
_ = ()

{- | An instrument or scale may put calls into scope.  If that instrument
    or scale is replaced with another, the old calls must be replaced with the
    new ones.

    Priority is determined by 'get_scopes', which returns them in the fields'
    declaration order.

    The reason this can't be accomplished just by arranging imports in the
    right order is that when an instrument or scale comes into scope, it needs
    to replace existing instrument or scale calls.  To do that, I need to keep
    each category separate.  Also, this way I can import the ky file once at
    the toplevel, and it will still override PrioBuiltin calls.
-}
newtype ScopePriority call = ScopePriority (Map CallPriority (CallMap call))
    deriving ([ScopePriority call] -> Doc
ScopePriority call -> Text
ScopePriority call -> Doc
(ScopePriority call -> Text)
-> (ScopePriority call -> Doc)
-> ([ScopePriority call] -> Doc)
-> Pretty (ScopePriority call)
forall call. [ScopePriority call] -> Doc
forall call. ScopePriority call -> Text
forall call. ScopePriority call -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [ScopePriority call] -> Doc
$cformatList :: forall call. [ScopePriority call] -> Doc
format :: ScopePriority call -> Doc
$cformat :: forall call. ScopePriority call -> Doc
pretty :: ScopePriority call -> Text
$cpretty :: forall call. ScopePriority call -> Text
Pretty)

instance Semigroup (ScopePriority call) where
    ScopePriority Map CallPriority (CallMap call)
a <> :: ScopePriority call -> ScopePriority call -> ScopePriority call
<> ScopePriority Map CallPriority (CallMap call)
b = Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority (Map CallPriority (CallMap call)
-> Map CallPriority (CallMap call)
-> Map CallPriority (CallMap call)
forall k a. (Ord k, Monoid a) => Map k a -> Map k a -> Map k a
Maps.mappend Map CallPriority (CallMap call)
a Map CallPriority (CallMap call)
b)
instance Monoid (ScopePriority call) where
    mempty :: ScopePriority call
mempty = Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority Map CallPriority (CallMap call)
forall a. Monoid a => a
mempty
    mappend :: ScopePriority call -> ScopePriority call -> ScopePriority call
mappend = ScopePriority call -> ScopePriority call -> ScopePriority call
forall a. Semigroup a => a -> a -> a
(<>)

data CallPriority =
    -- | Override calls shadow all others.  They're useful when you want to
    -- prevent instruments from overriding calls, which the lilypond deriver
    -- needs to do.
    PrioOverride
    -- | These are instrument-specific calls implicitly imported by note
    -- tracks.
    | PrioInstrument
    -- | Block calls are local definitions, so they should override builtin
    -- calls, but are still below instrument calls.  Otherwise, it's easy to
    -- define a block that shadows a drum stroke and get confused.
    -- TODO there could be a mechanism to set PrioOverride in case I actually
    -- do want to shadow an instrument call.
    | PrioBlock
    -- | This is for value calls introduced by a scale.  They are implicitly
    -- imported by pitch tracks.
    | PrioScale
    -- | Calls imported from the 'Builtins'.
    | PrioBuiltin
    deriving (Int -> CallPriority -> ShowS
[CallPriority] -> ShowS
CallPriority -> String
(Int -> CallPriority -> ShowS)
-> (CallPriority -> String)
-> ([CallPriority] -> ShowS)
-> Show CallPriority
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallPriority] -> ShowS
$cshowList :: [CallPriority] -> ShowS
show :: CallPriority -> String
$cshow :: CallPriority -> String
showsPrec :: Int -> CallPriority -> ShowS
$cshowsPrec :: Int -> CallPriority -> ShowS
Show, CallPriority -> CallPriority -> Bool
(CallPriority -> CallPriority -> Bool)
-> (CallPriority -> CallPriority -> Bool) -> Eq CallPriority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallPriority -> CallPriority -> Bool
$c/= :: CallPriority -> CallPriority -> Bool
== :: CallPriority -> CallPriority -> Bool
$c== :: CallPriority -> CallPriority -> Bool
Eq, Eq CallPriority
Eq CallPriority
-> (CallPriority -> CallPriority -> Ordering)
-> (CallPriority -> CallPriority -> Bool)
-> (CallPriority -> CallPriority -> Bool)
-> (CallPriority -> CallPriority -> Bool)
-> (CallPriority -> CallPriority -> Bool)
-> (CallPriority -> CallPriority -> CallPriority)
-> (CallPriority -> CallPriority -> CallPriority)
-> Ord CallPriority
CallPriority -> CallPriority -> Bool
CallPriority -> CallPriority -> Ordering
CallPriority -> CallPriority -> CallPriority
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CallPriority -> CallPriority -> CallPriority
$cmin :: CallPriority -> CallPriority -> CallPriority
max :: CallPriority -> CallPriority -> CallPriority
$cmax :: CallPriority -> CallPriority -> CallPriority
>= :: CallPriority -> CallPriority -> Bool
$c>= :: CallPriority -> CallPriority -> Bool
> :: CallPriority -> CallPriority -> Bool
$c> :: CallPriority -> CallPriority -> Bool
<= :: CallPriority -> CallPriority -> Bool
$c<= :: CallPriority -> CallPriority -> Bool
< :: CallPriority -> CallPriority -> Bool
$c< :: CallPriority -> CallPriority -> Bool
compare :: CallPriority -> CallPriority -> Ordering
$ccompare :: CallPriority -> CallPriority -> Ordering
Ord)

instance Pretty CallPriority where pretty :: CallPriority -> Text
pretty = CallPriority -> Text
forall a. Show a => a -> Text
showt

scope_priority :: [(CallPriority, CallMap call)] -> ScopePriority call
scope_priority :: forall call. [(CallPriority, CallMap call)] -> ScopePriority call
scope_priority = Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority (Map CallPriority (CallMap call) -> ScopePriority call)
-> ([(CallPriority, CallMap call)]
    -> Map CallPriority (CallMap call))
-> [(CallPriority, CallMap call)]
-> ScopePriority call
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CallPriority, CallMap call)] -> Map CallPriority (CallMap call)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

lookup_priority :: CallPriority -> ScopePriority call -> CallMap call
lookup_priority :: forall call. CallPriority -> ScopePriority call -> CallMap call
lookup_priority CallPriority
prio (ScopePriority Map CallPriority (CallMap call)
scopes) =
    CallMap call
-> CallPriority -> Map CallPriority (CallMap call) -> CallMap call
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault CallMap call
forall a. Monoid a => a
mempty CallPriority
prio Map CallPriority (CallMap call)
scopes

-- | Add this call at this level of priority.  It will shadow existing calls
-- with the same name.
add_priority :: CallPriority -> CallMap call -> ScopePriority call
    -> ScopePriority call
add_priority :: forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
add_priority CallPriority
prio CallMap call
cmap (ScopePriority Map CallPriority (CallMap call)
scopes) =
    Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority (Map CallPriority (CallMap call) -> ScopePriority call)
-> Map CallPriority (CallMap call) -> ScopePriority call
forall a b. (a -> b) -> a -> b
$ (CallMap call -> CallMap call -> CallMap call)
-> CallPriority
-> CallMap call
-> Map CallPriority (CallMap call)
-> Map CallPriority (CallMap call)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith CallMap call -> CallMap call -> CallMap call
forall a. Semigroup a => a -> a -> a
(<>) CallPriority
prio CallMap call
cmap Map CallPriority (CallMap call)
scopes

-- | Replace all calls at this level of priority.
replace_priority :: CallPriority -> CallMap call -> ScopePriority call
    -> ScopePriority call
replace_priority :: forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
replace_priority CallPriority
prio CallMap call
cmap (ScopePriority Map CallPriority (CallMap call)
scopes) =
    Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority (Map CallPriority (CallMap call) -> ScopePriority call)
-> Map CallPriority (CallMap call) -> ScopePriority call
forall a b. (a -> b) -> a -> b
$ CallPriority
-> CallMap call
-> Map CallPriority (CallMap call)
-> Map CallPriority (CallMap call)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CallPriority
prio CallMap call
cmap Map CallPriority (CallMap call)
scopes

-- | This is like 'Call', but with only documentation.  (name, CallDoc)
data DocumentedCall = DocumentedCall !CallName !CallDoc

extract_doc :: Call d -> DocumentedCall
extract_doc :: forall d. Call d -> DocumentedCall
extract_doc Call d
call = CallName -> CallDoc -> DocumentedCall
DocumentedCall (Call d -> CallName
forall func. Call func -> CallName
call_name Call d
call) (Call d -> CallDoc
forall func. Call func -> CallDoc
call_doc Call d
call)

extract_val_doc :: ValCall -> DocumentedCall
extract_val_doc :: ValCall -> DocumentedCall
extract_val_doc ValCall
vcall = CallName -> CallDoc -> DocumentedCall
DocumentedCall (ValCall -> CallName
vcall_name ValCall
vcall) (ValCall -> CallDoc
vcall_doc ValCall
vcall)

extract_track_doc :: TrackCall d -> DocumentedCall
extract_track_doc :: forall d. TrackCall d -> DocumentedCall
extract_track_doc TrackCall d
tcall = CallName -> CallDoc -> DocumentedCall
DocumentedCall (TrackCall d -> CallName
forall d. TrackCall d -> CallName
tcall_name TrackCall d
tcall) (TrackCall d -> CallDoc
forall d. TrackCall d -> CallDoc
tcall_doc TrackCall d
tcall)

-- ** TrackCall

data TrackCall d = TrackCall {
    forall d. TrackCall d -> CallName
tcall_name :: !CallName
    , forall d. TrackCall d -> CallDoc
tcall_doc :: !CallDoc
    , forall d. TrackCall d -> TrackCallFunc d
tcall_func :: !(TrackCallFunc d)
    }
type TrackCallFunc d =
    TrackTree.Track -> Deriver (ScoreT.Typed ScoreT.Control, d)

instance Show (TrackCall d) where
    show :: TrackCall d -> String
show TrackCall d
tcall = String
"((TrackCall " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallName -> String
forall a. Show a => a -> String
show (TrackCall d -> CallName
forall d. TrackCall d -> CallName
tcall_name TrackCall d
tcall) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"))"
instance Pretty (TrackCall d) where
    pretty :: TrackCall d -> Text
pretty = CallName -> Text
forall a. Pretty a => a -> Text
pretty (CallName -> Text)
-> (TrackCall d -> CallName) -> TrackCall d -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackCall d -> CallName
forall d. TrackCall d -> CallName
tcall_name

track_call :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
    -> TrackCallFunc d -> TrackCall d
track_call :: forall d.
Module -> CallName -> Tags -> Doc -> TrackCallFunc d -> TrackCall d
track_call Module
module_ CallName
name Tags
tags Doc
doc TrackCallFunc d
call = TrackCall
    { tcall_name :: CallName
tcall_name = CallName
name
    , tcall_doc :: CallDoc
tcall_doc = CallDoc
        { cdoc_module :: Module
cdoc_module = Module
module_
        , cdoc_tags :: Tags
cdoc_tags = Tags
tags
        , cdoc_doc :: Doc
cdoc_doc = Doc
doc
        , cdoc_args :: [ArgDoc]
cdoc_args = [ArgDoc]
forall a. Monoid a => a
mempty
        }
    , tcall_func :: TrackCallFunc d
tcall_func = TrackCallFunc d
call
    }

-- ** lookup

lookup_call :: Callable call => Expr.Symbol -> Deriver (Maybe call)
lookup_call :: forall call. Callable call => Symbol -> Deriver (Maybe call)
lookup_call = (Scopes -> ScopePriority call)
-> (Builtins -> ModuleMap call) -> Symbol -> Deriver (Maybe call)
forall call.
(Scopes -> ScopePriority call)
-> (Builtins -> ModuleMap call) -> Symbol -> Deriver (Maybe call)
lookup_call_with Scopes -> ScopePriority call
forall call. Callable call => Scopes -> ScopePriority call
get_scopes_scope Builtins -> ModuleMap call
forall call. Callable call => Builtins -> ModuleMap call
get_builtins_scope

lookup_call_with :: (Scopes -> ScopePriority call)
    -> (Builtins -> ModuleMap call) -> Expr.Symbol -> Deriver (Maybe call)
lookup_call_with :: forall call.
(Scopes -> ScopePriority call)
-> (Builtins -> ModuleMap call) -> Symbol -> Deriver (Maybe call)
lookup_call_with Scopes -> ScopePriority call
get_scopes Builtins -> ModuleMap call
get_builtins Symbol
sym = do
    [CallMap call]
cmaps <- (Scopes -> ScopePriority call) -> Deriver [CallMap call]
forall call.
(Scopes -> ScopePriority call) -> Deriver [CallMap call]
get_call_maps Scopes -> ScopePriority call
get_scopes
    [CallMap call] -> Symbol -> Deriver (Maybe call)
forall call. [CallMap call] -> Symbol -> Deriver (Maybe call)
lookup_call_maps [CallMap call]
cmaps Symbol
sym Deriver (Maybe call)
-> (Maybe call -> Deriver (Maybe call)) -> Deriver (Maybe call)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just call
call -> Maybe call -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe call -> Deriver (Maybe call))
-> Maybe call -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$ call -> Maybe call
forall a. a -> Maybe a
Just call
call
        Maybe call
Nothing -> case Symbol -> Maybe (Module, Symbol)
split_qualified Symbol
sym of
            Maybe (Module, Symbol)
Nothing -> Maybe call -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe call
forall a. Maybe a
Nothing
            Just (Module
mod, Symbol
sym) -> (Builtins -> ModuleMap call)
-> Module -> Symbol -> Deriver (Maybe call)
forall call.
(Builtins -> ModuleMap call)
-> Module -> Symbol -> Deriver (Maybe call)
lookup_qualified Builtins -> ModuleMap call
get_builtins Module
mod Symbol
sym

split_qualified :: Expr.Symbol -> Maybe (Module.Module, Expr.Symbol)
split_qualified :: Symbol -> Maybe (Module, Symbol)
split_qualified Symbol
sym
    | Text -> Bool
Text.null Text
mod Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
name = Maybe (Module, Symbol)
forall a. Maybe a
Nothing
    | Bool
otherwise = (Module, Symbol) -> Maybe (Module, Symbol)
forall a. a -> Maybe a
Just (Text -> Module
Module.Module (Int -> Text -> Text
Text.dropEnd Int
1 Text
mod), Text -> Symbol
Expr.Symbol Text
name)
    where (Text
mod, Text
name) = Text -> Text -> (Text, Text)
Text.breakOnEnd Text
"." (Symbol -> Text
Expr.unsym Symbol
sym)

lookup_qualified :: (Builtins -> ModuleMap call)
    -> Module.Module -> Expr.Symbol -> Deriver (Maybe call)
lookup_qualified :: forall call.
(Builtins -> ModuleMap call)
-> Module -> Symbol -> Deriver (Maybe call)
lookup_qualified Builtins -> ModuleMap call
get_scope Module
module_ Symbol
sym = do
    ModuleMap call
by_module <- (State -> ModuleMap call) -> Deriver State Error (ModuleMap call)
forall st a err. (st -> a) -> Deriver st err a
gets ((State -> ModuleMap call) -> Deriver State Error (ModuleMap call))
-> (State -> ModuleMap call)
-> Deriver State Error (ModuleMap call)
forall a b. (a -> b) -> a -> b
$ Builtins -> ModuleMap call
get_scope (Builtins -> ModuleMap call)
-> (State -> Builtins) -> State -> ModuleMap call
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constant -> Builtins
state_builtins (Constant -> Builtins) -> (State -> Constant) -> State -> Builtins
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant
    Maybe call -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe call -> Deriver (Maybe call))
-> Maybe call -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$ do
        CallMap call
cmap <- Module -> ModuleMap call -> Maybe (CallMap call)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
module_ ModuleMap call
by_module
        Symbol -> Map Symbol call -> Maybe call
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
sym (CallMap call -> Map Symbol call
forall call. CallMap call -> Map Symbol call
call_map CallMap call
cmap)

-- | Get CallMaps is 'CallPriority' order.
get_call_maps :: (Scopes -> ScopePriority call) -> Deriver [CallMap call]
get_call_maps :: forall call.
(Scopes -> ScopePriority call) -> Deriver [CallMap call]
get_call_maps Scopes -> ScopePriority call
get = do
    ScopePriority Map CallPriority (CallMap call)
scopes <- (State -> ScopePriority call)
-> Deriver State Error (ScopePriority call)
forall st a err. (st -> a) -> Deriver st err a
gets ((State -> ScopePriority call)
 -> Deriver State Error (ScopePriority call))
-> (State -> ScopePriority call)
-> Deriver State Error (ScopePriority call)
forall a b. (a -> b) -> a -> b
$ Scopes -> ScopePriority call
get (Scopes -> ScopePriority call)
-> (State -> Scopes) -> State -> ScopePriority call
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Scopes
state_scopes (Dynamic -> Scopes) -> (State -> Dynamic) -> State -> Scopes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic
    [CallMap call] -> Deriver [CallMap call]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CallMap call] -> Deriver [CallMap call])
-> [CallMap call] -> Deriver [CallMap call]
forall a b. (a -> b) -> a -> b
$ Map CallPriority (CallMap call) -> [CallMap call]
forall k a. Map k a -> [a]
Map.elems Map CallPriority (CallMap call)
scopes

-- | Find the symbol in the first CallMap.
lookup_call_maps :: [CallMap call] -> Expr.Symbol -> Deriver (Maybe call)
lookup_call_maps :: forall call. [CallMap call] -> Symbol -> Deriver (Maybe call)
lookup_call_maps [CallMap call]
lookups Symbol
sym = [Deriver State Error (Maybe call)]
-> Deriver State Error (Maybe call)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts ([Deriver State Error (Maybe call)]
 -> Deriver State Error (Maybe call))
-> [Deriver State Error (Maybe call)]
-> Deriver State Error (Maybe call)
forall a b. (a -> b) -> a -> b
$ (CallMap call -> Deriver State Error (Maybe call))
-> [CallMap call] -> [Deriver State Error (Maybe call)]
forall a b. (a -> b) -> [a] -> [b]
map (Symbol -> CallMap call -> Deriver State Error (Maybe call)
forall call. Symbol -> CallMap call -> Deriver (Maybe call)
lookup_call_map Symbol
sym) [CallMap call]
lookups

lookup_call_map :: Expr.Symbol -> CallMap call -> Deriver (Maybe call)
lookup_call_map :: forall call. Symbol -> CallMap call -> Deriver (Maybe call)
lookup_call_map Symbol
sym (CallMap Map Symbol call
cmap [PatternCall call]
patterns) = case Symbol -> Map Symbol call -> Maybe call
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
sym Map Symbol call
cmap of
    Just call
call -> Maybe call -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe call -> Deriver (Maybe call))
-> Maybe call -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$ call -> Maybe call
forall a. a -> Maybe a
Just call
call
    Maybe call
Nothing -> [Deriver (Maybe call)] -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts ([Deriver (Maybe call)] -> Deriver (Maybe call))
-> [Deriver (Maybe call)] -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$ (PatternCall call -> Deriver (Maybe call))
-> [PatternCall call] -> [Deriver (Maybe call)]
forall a b. (a -> b) -> [a] -> [b]
map (((Symbol -> Deriver (Maybe call)) -> Symbol -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$Symbol
sym) ((Symbol -> Deriver (Maybe call)) -> Deriver (Maybe call))
-> (PatternCall call -> Symbol -> Deriver (Maybe call))
-> PatternCall call
-> Deriver (Maybe call)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternCall call -> Symbol -> Deriver (Maybe call)
forall call. PatternCall call -> Symbol -> Deriver (Maybe call)
pat_function) [PatternCall call]
patterns

-- ** mode

-- | Derivation can run in a few distinct modes.
data Mode =
    -- | Standard derivation.
    Normal
    -- | This indicates that I'm running the deriver just to find out its
    -- duration.  There's a hack in "Derive.Eval" that will fill in
    -- 'collect_score_duration' when it sees this mode.  More detail in
    -- 'CallDuration'.
    | ScoreDurationQuery | RealDurationQuery
    -- | Emit events intended for the lilypond backend.  Calls that have
    -- corresponding staff notation (e.g. trills) emit special events with
    -- attached lilypond code in this mode.
    | Lilypond !Lilypond.Types.Config
    deriving (Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)

instance Pretty Mode where
    format :: Mode -> Doc
format (Lilypond Config
config) = Doc
"Lilypond" Doc -> Doc -> Doc
Pretty.<+> Config -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Config
config
    format Mode
mode = Text -> Doc
Pretty.text (Mode -> Text
forall a. Show a => a -> Text
showt Mode
mode)

-- * Constant

-- | Values that don't change during one derive run.
data Constant = Constant {
    Constant -> State
state_ui :: !Ui.State
    , Constant -> Builtins
state_builtins :: !Builtins
    -- | Global map of signal mergers.  Unlike calls, this is static.
    , Constant -> Map Symbol Merger
state_mergers :: !(Map Expr.Symbol Merger)
    -- | LookupScale is actually hardcoded to 'Derive.Scale.All.lookup_scale'.
    -- But using this means that if it ever becomes dynamic I hopefully don't
    -- have to change so much code.  Also I think it avoids a circular import.
    , Constant -> LookupScale
state_lookup_scale :: !LookupScale
    -- | Get the calls and environ that should be in scope with a certain
    -- instrument.  The environ is merged with the environ in effect.
    , Constant -> Instrument -> Either Text Instrument
state_lookup_instrument :: !(ScoreT.Instrument -> Either Text Instrument)
    -- | Cache from the last derivation.
    , Constant -> Cache
state_cache :: !Cache
    , Constant -> ScoreDamage
state_score_damage :: !ScoreDamage
    }

initial_constant :: Ui.State -> Builtins -> LookupScale
    -> (ScoreT.Instrument -> Either Text Instrument) -> Cache -> ScoreDamage
    -> Constant
initial_constant :: State
-> Builtins
-> LookupScale
-> (Instrument -> Either Text Instrument)
-> Cache
-> ScoreDamage
-> Constant
initial_constant State
ui_state Builtins
builtins LookupScale
lookup_scale Instrument -> Either Text Instrument
lookup_inst Cache
cache ScoreDamage
score_damage =
    Constant
        { state_ui :: State
state_ui = State
ui_state
        , state_builtins :: Builtins
state_builtins = Builtins
builtins
        , state_mergers :: Map Symbol Merger
state_mergers = Map Symbol Merger
mergers
        , state_lookup_scale :: LookupScale
state_lookup_scale = LookupScale
lookup_scale
        , state_lookup_instrument :: Instrument -> Either Text Instrument
state_lookup_instrument = Instrument -> Either Text Instrument
lookup_inst
        , state_cache :: Cache
state_cache = ScoreDamage -> Cache -> Cache
invalidate_damaged ScoreDamage
score_damage Cache
cache
        , state_score_damage :: ScoreDamage
state_score_damage = ScoreDamage
score_damage
        }

-- ** instrument

-- | Mostly the deriver just deals with instruments as strings, and doesn't
-- understand anything else about them.  However, it does need a few other
-- things, which are expressed here to avoid excessive dependencies between the
-- systems.
data Instrument = Instrument {
    Instrument -> InstrumentCalls
inst_calls :: !InstrumentCalls
    -- | Merge this with the 'state_environ' when the instrument comes into
    -- scope.
    , Instrument -> Environ
inst_environ :: !DeriveT.Environ
    -- | Like 'inst_environ', merge these controls.
    , Instrument -> ControlValMap
inst_controls :: !ScoreT.ControlValMap
    -- | This is a list of the attributes that the instrument understands, in
    -- order of priority.  It corresponds to 'Instrument.Common.AttributeMap'.
    , Instrument -> [Attributes]
inst_attributes :: ![Attrs.Attributes]
    , Instrument -> Set Text
inst_elements :: !(Set Shared.Note.Element)
    } deriving (Int -> Instrument -> ShowS
[Instrument] -> ShowS
Instrument -> String
(Int -> Instrument -> ShowS)
-> (Instrument -> String)
-> ([Instrument] -> ShowS)
-> Show Instrument
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instrument] -> ShowS
$cshowList :: [Instrument] -> ShowS
show :: Instrument -> String
$cshow :: Instrument -> String
showsPrec :: Int -> Instrument -> ShowS
$cshowsPrec :: Int -> Instrument -> ShowS
Show)

-- | Some ornaments only apply to a particular instrument, so each instrument
-- can bring a set of note calls and val calls into scope, via the 'Scope'
-- type.  This is like 'Builtins', but without the Module map, since they're
-- all implicitly in 'PrioInstrument'.
type InstrumentCalls = ScopesT
    (CallMap (Generator Note))
    (CallMap (Transformer Note))
    (CallMap (TrackCall Note))
    (CallMap ValCall)

instance Show InstrumentCalls where
    -- TODO this is probably pretty unreadable, but instrument calls are short.
    show :: InstrumentCalls -> String
show (Scopes CallMap (Generator Event)
gen CallMap (Transformer Event)
trans CallMap (TrackCall Event)
tracks CallMap ValCall
val) =
        String
"((InstrumentCalls "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [CallMap (Generator Event) -> String
forall a. Pretty a => a -> String
prettys CallMap (Generator Event)
gen, CallMap (Transformer Event) -> String
forall a. Pretty a => a -> String
prettys CallMap (Transformer Event)
trans, CallMap (TrackCall Event) -> String
forall a. Pretty a => a -> String
prettys CallMap (TrackCall Event)
tracks, CallMap ValCall -> String
forall a. Pretty a => a -> String
prettys CallMap ValCall
val]
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"))"

-- ** control

-- | How to merge a control into 'Dynamic'.
data Merge = DefaultMerge -- ^ Apply the default merge for this control.
    | Merge !Merger -- ^ Merge with a specific operator.
    deriving (Int -> Merge -> ShowS
[Merge] -> ShowS
Merge -> String
(Int -> Merge -> ShowS)
-> (Merge -> String) -> ([Merge] -> ShowS) -> Show Merge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Merge] -> ShowS
$cshowList :: [Merge] -> ShowS
show :: Merge -> String
$cshow :: Merge -> String
showsPrec :: Int -> Merge -> ShowS
$cshowsPrec :: Int -> Merge -> ShowS
Show)

instance Pretty Merge where pretty :: Merge -> Text
pretty = Merge -> Text
forall a. Show a => a -> Text
showt
instance DeepSeq.NFData Merge where rnf :: Merge -> ()
rnf Merge
_ = ()

-- | Combine two signals.  The element should be an identity, like mempty.
-- ControlMod uses it to avoid affecting signal outside of the modified range.
-- The merge function is not obliged to be associative, so this isn't actually
-- a monoid.  TODO it's all the fault of 'merge_scale'... do I lose something
-- important with associativity?
data Merger =
    -- | name merge identity
    Merger !Text !(Signal.Control -> Signal.Control -> Signal.Control) !Signal.Y
    | Set -- ^ Replace the existing signal.
    | Unset -- ^ Replace only if there is no existing signal.
    -- TODO I thought I'd need this but I don't.  If it turns out to never be
    -- useful I can delete it.

-- It's not really a 'DeriveT.Val', so this is a bit wrong for ShowVal.  But
-- I want to express that this is meant to be valid syntax for the track title.
instance ShowVal.ShowVal Merger where
    show_val :: Merger -> Text
show_val Merger
Set = Text
"set"
    show_val Merger
Unset = Text
"unset"
    show_val (Merger Text
name Control -> Control -> Control
_ Y
_) = Text
name
instance Pretty Merger where pretty :: Merger -> Text
pretty = Merger -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val
instance Show Merger where
    show :: Merger -> String
show Merger
merger = String
"((Merger " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
untxt (Merger -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Merger
merger) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"))"
instance DeepSeq.NFData Merger where rnf :: Merger -> ()
rnf Merger
_ = ()

-- *** control ops

-- | The built-in set of control Mergers.
mergers :: Map Expr.Symbol Merger
mergers :: Map Symbol Merger
mergers = [(Symbol, Merger)] -> Map Symbol Merger
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Symbol, Merger)] -> Map Symbol Merger)
-> [(Symbol, Merger)] -> Map Symbol Merger
forall a b. (a -> b) -> a -> b
$ (Merger -> (Symbol, Merger)) -> [Merger] -> [(Symbol, Merger)]
forall a b. (a -> b) -> [a] -> [b]
map Merger -> (Symbol, Merger)
forall {b}. ShowVal b => b -> (Symbol, b)
to_pair
    [ Merger
Set, Merger
merge_add, Merger
merge_sub, Merger
merge_mul, Merger
merge_scale
    ]
    where to_pair :: b -> (Symbol, b)
to_pair b
merger = (Text -> Symbol
Expr.Symbol (b -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val b
merger), b
merger)

merge_add, merge_sub, merge_mul :: Merger
merge_add :: Merger
merge_add = Text -> (Control -> Control -> Control) -> Y -> Merger
Merger Text
"add" Control -> Control -> Control
Signal.sig_add Y
0
merge_sub :: Merger
merge_sub = Text -> (Control -> Control -> Control) -> Y -> Merger
Merger Text
"sub" Control -> Control -> Control
Signal.sig_subtract Y
0
merge_mul :: Merger
merge_mul = Text -> (Control -> Control -> Control) -> Y -> Merger
Merger Text
"mul" Control -> Control -> Control
Signal.sig_multiply Y
1

-- | Unlike the rest, this one is not associative.
merge_scale :: Merger
merge_scale :: Merger
merge_scale = Text -> (Control -> Control -> Control) -> Y -> Merger
Merger Text
"scale" Control -> Control -> Control
Signal.sig_scale Y
0


-- * Collect

-- | These are things that collect throughout derivation, and are cached in
-- addition to the derived values.  Effectively they are extra return values,
-- which are combined with mappend.  So this is the WriterT part of 'State'.
data Collect = Collect {
    -- | Remember the warp signal for each track.  A warp usually applies to
    -- a set of tracks, so remembering them together will make the play monitor
    -- more efficient when it inverts them to get playback position.
    Collect -> WarpMap
collect_warp_map :: !TrackWarp.WarpMap
    , Collect -> TrackSignals
collect_track_signals :: !Track.TrackSignals
    , Collect -> SignalFragments
collect_signal_fragments :: !SignalFragments
    , Collect -> TrackDynamic
collect_track_dynamic :: !TrackDynamic
    -- | I prefer the Dynamic from the inverted version of a track, if it
    -- exists.  But I want the controls to come from the non-inverted version,
    -- since they are sliced to a particular event in the inverted version.
    -- So I record both, and merge them together at the end.
    , Collect -> TrackDynamic
collect_track_dynamic_inverted :: !TrackDynamic
    -- | This is how a call records its dependencies.  After evaluation of
    -- a deriver, this will contain the dependencies of the most recent call.
    , Collect -> BlockDeps
collect_block_deps :: !BlockDeps

    -- | New caches accumulating over the course of the derivation.
    , Collect -> Cache
collect_cache :: !Cache
    , Collect -> CacheStats
collect_cache_stats :: !CacheStats
    , Collect -> [Integrated]
collect_integrated :: ![Integrated]
    , Collect -> [ControlMod]
collect_control_mods :: ![ControlMod]
    , Collect -> CallDuration ScoreTime
collect_score_duration :: !(CallDuration ScoreTime)
    , Collect -> CallDuration RealTime
collect_real_duration :: !(CallDuration RealTime)
    }

data CacheStats = CacheStats {
    -- This isn't Ranges RealTime because I don't want to allow
    -- Ranges.Everything.
    CacheStats -> [(Either BlockId TrackId, (RealTime, RealTime))]
cstats_hits :: ![(Either BlockId TrackId, (RealTime, RealTime))]
    } deriving (CacheStats -> CacheStats -> Bool
(CacheStats -> CacheStats -> Bool)
-> (CacheStats -> CacheStats -> Bool) -> Eq CacheStats
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheStats -> CacheStats -> Bool
$c/= :: CacheStats -> CacheStats -> Bool
== :: CacheStats -> CacheStats -> Bool
$c== :: CacheStats -> CacheStats -> Bool
Eq, Int -> CacheStats -> ShowS
[CacheStats] -> ShowS
CacheStats -> String
(Int -> CacheStats -> ShowS)
-> (CacheStats -> String)
-> ([CacheStats] -> ShowS)
-> Show CacheStats
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheStats] -> ShowS
$cshowList :: [CacheStats] -> ShowS
show :: CacheStats -> String
$cshow :: CacheStats -> String
showsPrec :: Int -> CacheStats -> ShowS
$cshowsPrec :: Int -> CacheStats -> ShowS
Show)

instance Pretty CacheStats where
    format :: CacheStats -> Doc
format (CacheStats [(Either BlockId TrackId, (RealTime, RealTime))]
hits) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"CacheStats"
        [ (Text
"hits", [(Either BlockId TrackId, (RealTime, RealTime))] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [(Either BlockId TrackId, (RealTime, RealTime))]
hits)
        ]

instance Semigroup CacheStats where
    CacheStats [(Either BlockId TrackId, (RealTime, RealTime))]
hits1 <> :: CacheStats -> CacheStats -> CacheStats
<> CacheStats [(Either BlockId TrackId, (RealTime, RealTime))]
hits2 = [(Either BlockId TrackId, (RealTime, RealTime))] -> CacheStats
CacheStats ([(Either BlockId TrackId, (RealTime, RealTime))]
hits1 [(Either BlockId TrackId, (RealTime, RealTime))]
-> [(Either BlockId TrackId, (RealTime, RealTime))]
-> [(Either BlockId TrackId, (RealTime, RealTime))]
forall a. Semigroup a => a -> a -> a
<> [(Either BlockId TrackId, (RealTime, RealTime))]
hits2)
instance Monoid CacheStats where
    mempty :: CacheStats
mempty = [(Either BlockId TrackId, (RealTime, RealTime))] -> CacheStats
CacheStats [(Either BlockId TrackId, (RealTime, RealTime))]
forall a. Monoid a => a
mempty
    mappend :: CacheStats -> CacheStats -> CacheStats
mappend = CacheStats -> CacheStats -> CacheStats
forall a. Semigroup a => a -> a -> a
(<>)

-- | These are fragments of a signal, which will be later collected into
-- 'collect_track_signals'.  This is part of a complicated mechanism to
-- evaluate TrackSignals only once.  When the sliced fragments of a track are
-- evaluated, they collect signal fragments.  When the track is fully
-- evaluated, they are sorted and merged into 'collect_track_signals'.
-- If the track is then evaluated again, the monoid instance will discard the
-- duplicate.
--
-- The signal fragments are indexed by the slice position.  Since
-- 'Signal.merge' makes the earlier signals win in case of overlaps, this
-- ensures a trimmed earlier fragment won't replace a more complete later one.
type SignalFragments = Map (BlockId, TrackId) (Map TrackTime Signal.Control)

instance Pretty Collect where
    format :: Collect -> Doc
format (Collect WarpMap
warp_map TrackSignals
tsigs SignalFragments
frags TrackDynamic
trackdyn TrackDynamic
trackdyn_inv BlockDeps
deps
            Cache
cache CacheStats
cache_stats [Integrated]
integrated [ControlMod]
cmods CallDuration ScoreTime
call_dur CallDuration RealTime
call_end) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Collect"
            [ (Text
"warp_map", WarpMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format WarpMap
warp_map)
            , (Text
"track_signals", TrackSignals -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackSignals
tsigs)
            , (Text
"signal_fragments", SignalFragments -> Doc
forall a. Pretty a => a -> Doc
Pretty.format SignalFragments
frags)
            , (Text
"track_dynamic", TrackDynamic -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackDynamic
trackdyn)
            , (Text
"track_dynamic_inverted", TrackDynamic -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackDynamic
trackdyn_inv)
            , (Text
"block_deps", BlockDeps -> Doc
forall a. Pretty a => a -> Doc
Pretty.format BlockDeps
deps)
            , (Text
"cache", Cache -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Cache
cache)
            , (Text
"cache_stats", CacheStats -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CacheStats
cache_stats)
            , (Text
"integrated", [Integrated] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Integrated]
integrated)
            , (Text
"control_mods", [ControlMod] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [ControlMod]
cmods)
            , (Text
"call duration", CallDuration ScoreTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CallDuration ScoreTime
call_dur)
            , (Text
"call end", CallDuration RealTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CallDuration RealTime
call_end)
            ]

instance Semigroup Collect where
    <> :: Collect -> Collect -> Collect
(<>)    (Collect WarpMap
warps1 TrackSignals
tsigs1 SignalFragments
frags1 TrackDynamic
trackdyn1 TrackDynamic
trackdyn_inv1 BlockDeps
deps1
                Cache
cache1 CacheStats
cstats1 [Integrated]
integrated1 [ControlMod]
cmods1 CallDuration ScoreTime
cdur1 CallDuration RealTime
cend1)
            (Collect WarpMap
warps2 TrackSignals
tsigs2 SignalFragments
frags2 TrackDynamic
trackdyn2 TrackDynamic
trackdyn_inv2 BlockDeps
deps2
                Cache
cache2 CacheStats
cstats2 [Integrated]
integrated2 [ControlMod]
cmods2 CallDuration ScoreTime
cdur2 CallDuration RealTime
cend2) =
        WarpMap
-> TrackSignals
-> SignalFragments
-> TrackDynamic
-> TrackDynamic
-> BlockDeps
-> Cache
-> CacheStats
-> [Integrated]
-> [ControlMod]
-> CallDuration ScoreTime
-> CallDuration RealTime
-> Collect
Collect (WarpMap
warps1 WarpMap -> WarpMap -> WarpMap
forall a. Semigroup a => a -> a -> a
<> WarpMap
warps2)
            (TrackSignals
tsigs1 TrackSignals -> TrackSignals -> TrackSignals
forall a. Semigroup a => a -> a -> a
<> TrackSignals
tsigs2) ((Map ScoreTime Control
 -> Map ScoreTime Control -> Map ScoreTime Control)
-> SignalFragments -> SignalFragments -> SignalFragments
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Map ScoreTime Control
-> Map ScoreTime Control -> Map ScoreTime Control
forall a. Semigroup a => a -> a -> a
(<>) SignalFragments
frags1 SignalFragments
frags2)
            (TrackDynamic
trackdyn1 TrackDynamic -> TrackDynamic -> TrackDynamic
forall a. Semigroup a => a -> a -> a
<> TrackDynamic
trackdyn2) (TrackDynamic
trackdyn_inv1 TrackDynamic -> TrackDynamic -> TrackDynamic
forall a. Semigroup a => a -> a -> a
<> TrackDynamic
trackdyn_inv2)
            (BlockDeps
deps1 BlockDeps -> BlockDeps -> BlockDeps
forall a. Semigroup a => a -> a -> a
<> BlockDeps
deps2) (Cache
cache1 Cache -> Cache -> Cache
forall a. Semigroup a => a -> a -> a
<> Cache
cache2) (CacheStats
cstats1 CacheStats -> CacheStats -> CacheStats
forall a. Semigroup a => a -> a -> a
<> CacheStats
cstats2)
            ([Integrated]
integrated1 [Integrated] -> [Integrated] -> [Integrated]
forall a. Semigroup a => a -> a -> a
<> [Integrated]
integrated2) ([ControlMod]
cmods1 [ControlMod] -> [ControlMod] -> [ControlMod]
forall a. Semigroup a => a -> a -> a
<> [ControlMod]
cmods2) (CallDuration ScoreTime
cdur1 CallDuration ScoreTime
-> CallDuration ScoreTime -> CallDuration ScoreTime
forall a. Semigroup a => a -> a -> a
<> CallDuration ScoreTime
cdur2)
            (CallDuration RealTime
cend1 CallDuration RealTime
-> CallDuration RealTime -> CallDuration RealTime
forall a. Semigroup a => a -> a -> a
<> CallDuration RealTime
cend2)
instance Monoid Collect where
    mempty :: Collect
mempty = WarpMap
-> TrackSignals
-> SignalFragments
-> TrackDynamic
-> TrackDynamic
-> BlockDeps
-> Cache
-> CacheStats
-> [Integrated]
-> [ControlMod]
-> CallDuration ScoreTime
-> CallDuration RealTime
-> Collect
Collect WarpMap
forall a. Monoid a => a
mempty TrackSignals
forall a. Monoid a => a
mempty SignalFragments
forall a. Monoid a => a
mempty TrackDynamic
forall a. Monoid a => a
mempty TrackDynamic
forall a. Monoid a => a
mempty BlockDeps
forall a. Monoid a => a
mempty Cache
forall a. Monoid a => a
mempty CacheStats
forall a. Monoid a => a
mempty
        [Integrated]
forall a. Monoid a => a
mempty [ControlMod]
forall a. Monoid a => a
mempty CallDuration ScoreTime
forall a. Monoid a => a
mempty CallDuration RealTime
forall a. Monoid a => a
mempty
    mappend :: Collect -> Collect -> Collect
mappend = Collect -> Collect -> Collect
forall a. Semigroup a => a -> a -> a
(<>)

instance DeepSeq.NFData Collect where
    rnf :: Collect -> ()
rnf (Collect WarpMap
warp_map TrackSignals
frags SignalFragments
tsigs TrackDynamic
track_dyn TrackDynamic
track_dyn_inv BlockDeps
local_dep
            Cache
cache CacheStats
_cstats [Integrated]
integrated [ControlMod]
_cmods CallDuration ScoreTime
_cdur CallDuration RealTime
_cend) =
        WarpMap -> ()
forall a. NFData a => a -> ()
rnf WarpMap
warp_map () -> () -> ()
`seq` TrackSignals -> ()
forall a. NFData a => a -> ()
rnf TrackSignals
frags () -> () -> ()
`seq` SignalFragments -> ()
forall a. NFData a => a -> ()
rnf SignalFragments
tsigs () -> () -> ()
`seq` TrackDynamic -> ()
forall a. NFData a => a -> ()
rnf TrackDynamic
track_dyn
        () -> () -> ()
`seq` TrackDynamic -> ()
forall a. NFData a => a -> ()
rnf TrackDynamic
track_dyn_inv () -> () -> ()
`seq` BlockDeps -> ()
forall a. NFData a => a -> ()
rnf BlockDeps
local_dep () -> () -> ()
`seq` Cache -> ()
forall a. NFData a => a -> ()
rnf Cache
cache
        () -> () -> ()
`seq` [Integrated] -> ()
forall a. NFData a => a -> ()
rnf [Integrated]
integrated

-- | This is a hack so a call on a control track can modify other controls.
-- The motivating case is pitch ornaments that also want to affect the
-- dynamics.  The modifications are a secondary return value from control
-- and pitch calls.  The track deriver will extract them and merge them into
-- the dynamic environment.  [NOTE control-modification]
data ControlMod = ControlMod !ScoreT.Control !Signal.Control !Merger
    deriving (Int -> ControlMod -> ShowS
[ControlMod] -> ShowS
ControlMod -> String
(Int -> ControlMod -> ShowS)
-> (ControlMod -> String)
-> ([ControlMod] -> ShowS)
-> Show ControlMod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlMod] -> ShowS
$cshowList :: [ControlMod] -> ShowS
show :: ControlMod -> String
$cshow :: ControlMod -> String
showsPrec :: Int -> ControlMod -> ShowS
$cshowsPrec :: Int -> ControlMod -> ShowS
Show)

instance Pretty ControlMod where
    format :: ControlMod -> Doc
format (ControlMod Control
control Control
signal Merger
merge) =
        Text -> [Doc] -> Doc
Pretty.constructor Text
"ControlMod"
            [Control -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Control
control, Control -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Control
signal, Merger -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Merger
merge]

data Integrated = Integrated {
    -- BlockId for a block integration, TrackId for a track integration.
    Integrated -> Either BlockId TrackId
integrated_source :: !(Either BlockId TrackId)
    , Integrated -> Stream Event
integrated_events :: !(Stream.Stream Score.Event)
    } deriving (Int -> Integrated -> ShowS
[Integrated] -> ShowS
Integrated -> String
(Int -> Integrated -> ShowS)
-> (Integrated -> String)
-> ([Integrated] -> ShowS)
-> Show Integrated
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Integrated] -> ShowS
$cshowList :: [Integrated] -> ShowS
show :: Integrated -> String
$cshow :: Integrated -> String
showsPrec :: Int -> Integrated -> ShowS
$cshowsPrec :: Int -> Integrated -> ShowS
Show)

instance Pretty Integrated where
    format :: Integrated -> Doc
format (Integrated Either BlockId TrackId
source Stream Event
events) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Integrated"
        [ (Text
"source", Either BlockId TrackId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Either BlockId TrackId
source)
        , (Text
"events", Stream Event -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stream Event
events)
        ]

instance DeepSeq.NFData Integrated where
    rnf :: Integrated -> ()
rnf (Integrated Either BlockId TrackId
source Stream Event
events) = Either BlockId TrackId -> ()
forall a. NFData a => a -> ()
rnf Either BlockId TrackId
source () -> () -> ()
`seq` Stream Event -> ()
forall a. NFData a => a -> ()
rnf Stream Event
events

{- | Snapshots of the environ at each track.  This is used by the Cmd layer to
    figure out what the scale and instrument are for a given track.

    Originally this was a map from Stacks to Environ (and only the changed
    parts).  The idea was that I could walk up the stack to find the Environ
    value in scope at a given point, and given Stack.Region, could even get
    e.g. per event instruments.  Unfortunately, while it's easy to do that on
    the Derive side, it seems really complicated and somewhat expensive to try
    to retrace a complete stack on every cmd.  Since this implementation
    doesn't store the entire stack, a track with a different instrument at
    different times will wind up with the last one.

    This is a much simpler solution which will hopefully work well enough in
    practice.

    NOTE [record-track-dynamics] One complication is that when I get controls
    from sliced tracks, the controls are also sliced.  But I need the environ
    from the inverted version of the track so the common case of [>i, *scale]
    gets the correct scale.  So I record TrackDynamic for both inverted and non
    inverted tracks and prefer the inverted tracks, but take controls from the
    non-inverted versions.
-}
type TrackDynamic = Map (BlockId, TrackId) Dynamic

{- | This is the logical duration of a call.  This may be different from its
    actual duration (which is to say, the end time of the last event it emits).
    Also, while most calls adjust their duration to the duration of the event
    they are called from, some of them have their own intrinsic duration.  For
    example, a block call may stretch to its calling event's duration, but it
    also has its own duration that is used to align the block's end, or to
    sequence blocks.

    Since the call duration is sometimes used to place the call in the first
    place (e.g. to align its end), I want to evaluate the minimum amount
    necessary to find the duration.  The implementation is that each generator
    call has a 'gfunc_score_duration' field.  When "Derive.Eval" is evaluating
    a generator call, if it sees that 'state_mode' is 'ScoreDurationQuery',
    instead of calling 'gfunc_f', it will call gfunc_score_duration and return
    the result via 'collect_score_duration'.  You shouldn't stick your fingers
    into this machinery, but instead use @Derive.get_call_duration@ to do the
    gefingerpoken for you.

    I'm not very happy with this implementation, but I tried several approaches
    and this is the only one that worked.  Historical details are in
    NOTE [call-duration].
-}
data CallDuration a = Unknown | CallDuration !a
    deriving (CallDuration a -> CallDuration a -> Bool
(CallDuration a -> CallDuration a -> Bool)
-> (CallDuration a -> CallDuration a -> Bool)
-> Eq (CallDuration a)
forall a. Eq a => CallDuration a -> CallDuration a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallDuration a -> CallDuration a -> Bool
$c/= :: forall a. Eq a => CallDuration a -> CallDuration a -> Bool
== :: CallDuration a -> CallDuration a -> Bool
$c== :: forall a. Eq a => CallDuration a -> CallDuration a -> Bool
Eq, Int -> CallDuration a -> ShowS
[CallDuration a] -> ShowS
CallDuration a -> String
(Int -> CallDuration a -> ShowS)
-> (CallDuration a -> String)
-> ([CallDuration a] -> ShowS)
-> Show (CallDuration a)
forall a. Show a => Int -> CallDuration a -> ShowS
forall a. Show a => [CallDuration a] -> ShowS
forall a. Show a => CallDuration a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallDuration a] -> ShowS
$cshowList :: forall a. Show a => [CallDuration a] -> ShowS
show :: CallDuration a -> String
$cshow :: forall a. Show a => CallDuration a -> String
showsPrec :: Int -> CallDuration a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> CallDuration a -> ShowS
Show)

instance Show a => Pretty (CallDuration a) where pretty :: CallDuration a -> Text
pretty = CallDuration a -> Text
forall a. Show a => a -> Text
showt

-- I think it would be more correct to take the stack depth, and pick the one
-- with the shallower stack, and then the max.  But it's more expensive and
-- picking the second one seems to work.
instance Semigroup (CallDuration a) where
    CallDuration a
Unknown <> :: CallDuration a -> CallDuration a -> CallDuration a
<> CallDuration a
a = CallDuration a
a
    CallDuration a
a <> CallDuration a
Unknown = CallDuration a
a
    CallDuration a
_ <> CallDuration a
a = CallDuration a
a
instance Monoid (CallDuration a) where
    mempty :: CallDuration a
mempty = CallDuration a
forall a. CallDuration a
Unknown
    mappend :: CallDuration a -> CallDuration a -> CallDuration a
mappend = CallDuration a -> CallDuration a -> CallDuration a
forall a. Semigroup a => a -> a -> a
(<>)

-- ** calls

data PatternCall call = PatternCall {
    -- | Since this doesn't have a Symbol, this is a description of the kinds
    -- of symbols matched, presumably as a regex.
    forall call. PatternCall call -> Text
pat_description :: !Text
    , forall call. PatternCall call -> DocumentedCall
pat_doc :: !DocumentedCall
    -- | The function is in Deriver because some calls want to look at the
    -- state to know if the Symbol is valid, e.g. block calls.
    , forall call. PatternCall call -> Symbol -> Deriver (Maybe call)
pat_function :: !(Expr.Symbol -> Deriver (Maybe call))
    }

pat_call_doc :: PatternCall call -> CallDoc
pat_call_doc :: forall call. PatternCall call -> CallDoc
pat_call_doc PatternCall call
pattern = CallDoc
doc
    where DocumentedCall CallName
_ CallDoc
doc = PatternCall call -> DocumentedCall
forall call. PatternCall call -> DocumentedCall
pat_doc PatternCall call
pattern

instance Pretty (PatternCall call) where
    pretty :: PatternCall call -> Text
pretty PatternCall call
pattern = Text
"Pattern:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PatternCall call -> Text
forall call. PatternCall call -> Text
pat_description PatternCall call
pattern

-- | Data passed to a 'Call'.
data PassedArgs val = PassedArgs {
    forall val. PassedArgs val -> [Val]
passed_vals :: ![DeriveT.Val]
    -- | Used by "Derive.Sig" to look for default arg values in the
    -- environment.  This is technically redundant since a call should know its
    -- own name, but it turns out to be inconvenient to pass the name to all of
    -- those functions.
    , forall val. PassedArgs val -> CallName
passed_call_name :: !CallName
    , forall val. PassedArgs val -> Context val
passed_ctx :: !(Context val)
    } deriving ((forall a b. (a -> b) -> PassedArgs a -> PassedArgs b)
-> (forall a b. a -> PassedArgs b -> PassedArgs a)
-> Functor PassedArgs
forall a b. a -> PassedArgs b -> PassedArgs a
forall a b. (a -> b) -> PassedArgs a -> PassedArgs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> PassedArgs b -> PassedArgs a
$c<$ :: forall a b. a -> PassedArgs b -> PassedArgs a
fmap :: forall a b. (a -> b) -> PassedArgs a -> PassedArgs b
$cfmap :: forall a b. (a -> b) -> PassedArgs a -> PassedArgs b
Functor)

instance Pretty val => Pretty (PassedArgs val) where
    format :: PassedArgs val -> Doc
format (PassedArgs [Val]
vals CallName
call_name Context val
info) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"PassedArgs"
        [ (Text
"vals", [Val] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Val]
vals)
        , (Text
"call_name", CallName -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CallName
call_name)
        , (Text
"info", Context val -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Context val
info)
        ]

-- | Additional data for a call.  This part is invariant for all calls on
-- an event.
--
-- The events are not used for transform calls.
--
-- TODO make separate types so the irrelevent data need not be passed?
data Context val = Context {
    -- The below is not used at all for val calls, and the events are not
    -- used for transform calls.  It might be cleaner to split those out, but
    -- too much bother.

    -- | Hack so control calls have access to the previous sample, since
    -- they tend to want to interpolate from that value.
    --
    -- This used to be the only way a call could get the previous value, but
    -- now if the prev val is unset, then "Derive.Args.prev_val" will evaluate
    -- 'ctx_prev_events'.  But checking ctx_prev_val is cheaper, so I'll keep
    -- it around.  The evaluation fallback has to exist because track slicing
    -- may snip off the previous event.
    --
    -- See NOTE [prev-val] in "Derive.Args" for details.
    forall val. Context val -> Maybe val
ctx_prev_val :: !(Maybe val)

    , forall val. Context val -> Event
ctx_event :: !Event.Event
    , forall val. Context val -> [Event]
ctx_prev_events :: ![Event.Event]
    , forall val. Context val -> [Event]
ctx_next_events :: ![Event.Event]

    -- | The extent of the note past its duration.  Since notes have decay,
    -- its important to capture control for that.  Normally this is the next
    -- event's start.  If there's no next event because it's the last event of
    -- the block, this is the block end, otherwise if there's no next event
    -- because it was sliced off, this is where that event would have started.
    --
    -- This is the same as the first element of 'ctx_next_events' except of
    -- course it has a value even when there is no next event.
    , forall val. Context val -> ScoreTime
ctx_event_end :: !ScoreTime
    -- | From 'TrackTree.track_shifted'.
    , forall val. Context val -> ScoreTime
ctx_track_shifted :: !TrackTime

    -- | The track tree below note tracks.  Not given for control tracks.
    -- TODO should this be Either with ctx_sub_events?  I don't think I ever
    -- need both set.
    , forall val. Context val -> EventsTree
ctx_sub_tracks :: !TrackTree.EventsTree
    -- | If present, 'Derive.Sub.sub_events' will directly return these sub
    -- events instead of slicing sub-tracks.  Track evaluation will never set
    -- this, but calls can set this to reapply a note parent.  It should
    -- be 'Derive.SubT.Event's, but isn't to avoid circular imports.
    , forall val.
Context val -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
ctx_sub_events :: !(Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]])
    -- | This is needed by val calls that want to evaluate events around them.
    -- Since val calls are the same on all track types, they need to know
    -- explicitly what the track type is to evaluate events on it.
    , forall val. Context val -> Maybe Type
ctx_track_type :: !(Maybe ParseTitle.Type)
    } deriving ((forall a b. (a -> b) -> Context a -> Context b)
-> (forall a b. a -> Context b -> Context a) -> Functor Context
forall a b. a -> Context b -> Context a
forall a b. (a -> b) -> Context a -> Context b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Context b -> Context a
$c<$ :: forall a b. a -> Context b -> Context a
fmap :: forall a b. (a -> b) -> Context a -> Context b
$cfmap :: forall a b. (a -> b) -> Context a -> Context b
Functor)

-- | Range of the event in TrackTime.
ctx_track_range :: Context a -> (TrackTime, TrackTime)
ctx_track_range :: forall a. Context a -> (ScoreTime, ScoreTime)
ctx_track_range Context a
info = (ScoreTime
shifted, ScoreTime
shifted ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ Context a -> ScoreTime
forall val. Context val -> ScoreTime
ctx_event_end Context a
info)
    where shifted :: ScoreTime
shifted = Context a -> ScoreTime
forall val. Context val -> ScoreTime
ctx_track_shifted Context a
info

instance Pretty val => Pretty (Context val) where
    format :: Context val -> Doc
format (Context Maybe val
prev_val Event
event [Event]
prev_events [Event]
next_events ScoreTime
event_end
            ScoreTime
track_range EventsTree
sub_tracks Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
sub_events Maybe Type
track_type) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Context"
            [ (Text
"prev_val", Maybe val -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe val
prev_val)
            , (Text
"event", Event -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Event
event)
            , (Text
"prev_events", [Event] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Event]
prev_events)
            , (Text
"next_events", [Event] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Event]
next_events)
            , (Text
"event_end", ScoreTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ScoreTime
event_end)
            , (Text
"track_range", ScoreTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ScoreTime
track_range)
            , (Text
"sub_tracks", EventsTree -> Doc
forall a. Pretty a => a -> Doc
Pretty.format EventsTree
sub_tracks)
            , (Text
"sub_events", Maybe [[(ScoreTime, ScoreTime)]] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Maybe [[(ScoreTime, ScoreTime)]] -> Doc)
-> Maybe [[(ScoreTime, ScoreTime)]] -> Doc
forall a b. (a -> b) -> a -> b
$
                ([(ScoreTime, ScoreTime, NoteDeriver)] -> [(ScoreTime, ScoreTime)])
-> [[(ScoreTime, ScoreTime, NoteDeriver)]]
-> [[(ScoreTime, ScoreTime)]]
forall a b. (a -> b) -> [a] -> [b]
map (((ScoreTime, ScoreTime, NoteDeriver) -> (ScoreTime, ScoreTime))
-> [(ScoreTime, ScoreTime, NoteDeriver)]
-> [(ScoreTime, ScoreTime)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ScoreTime
s, ScoreTime
d, NoteDeriver
_) -> (ScoreTime
s, ScoreTime
d))) ([[(ScoreTime, ScoreTime, NoteDeriver)]]
 -> [[(ScoreTime, ScoreTime)]])
-> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
-> Maybe [[(ScoreTime, ScoreTime)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
sub_events)
            , (Text
"track_type", Maybe Type -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe Type
track_type)
            ]

coerce_context :: Context a -> Context b
coerce_context :: forall a b. Context a -> Context b
coerce_context Context a
ctx = Context a
ctx { ctx_prev_val :: Maybe b
ctx_prev_val = Maybe b
forall a. Maybe a
Nothing }

-- | Transformer calls don't necessarily apply to any particular event, and
-- neither do generators for that matter.
dummy_context :: ScoreTime -> ScoreTime -> Text -> Context a
dummy_context :: forall a. ScoreTime -> ScoreTime -> Text -> Context a
dummy_context ScoreTime
start ScoreTime
dur Text
text = Context
    { ctx_prev_val :: Maybe a
ctx_prev_val = Maybe a
forall a. Maybe a
Nothing
    , ctx_event :: Event
ctx_event = ScoreTime -> ScoreTime -> Text -> Event
Event.event ScoreTime
start ScoreTime
dur Text
text
    , ctx_prev_events :: [Event]
ctx_prev_events = []
    , ctx_next_events :: [Event]
ctx_next_events = []
    , ctx_event_end :: ScoreTime
ctx_event_end = ScoreTime
start ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ ScoreTime
dur
    , ctx_track_shifted :: ScoreTime
ctx_track_shifted = ScoreTime
0
    , ctx_sub_tracks :: EventsTree
ctx_sub_tracks = []
    , ctx_sub_events :: Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
ctx_sub_events = Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
forall a. Maybe a
Nothing
    , ctx_track_type :: Maybe Type
ctx_track_type = Maybe Type
forall a. Maybe a
Nothing
    }

-- | Taggable the polymorphic part of the Context so it can be given to
-- a 'ValCall'.  Otherwise, ValCall would have to be polymorphic too,
-- which means it would hard to write generic ones.
tag_context :: Taggable a => Context a -> Context Tagged
tag_context :: forall a. Taggable a => Context a -> Context Tagged
tag_context Context a
ctx = Context a
ctx { ctx_prev_val :: Maybe Tagged
ctx_prev_val = a -> Tagged
forall a. Taggable a => a -> Tagged
to_tagged (a -> Tagged) -> Maybe a -> Maybe Tagged
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context a -> Maybe a
forall val. Context val -> Maybe val
ctx_prev_val Context a
ctx }

untag_context :: Taggable a => Context Tagged -> Context a
untag_context :: forall a. Taggable a => Context Tagged -> Context a
untag_context Context Tagged
ctx = Context Tagged
ctx { ctx_prev_val :: Maybe a
ctx_prev_val = Tagged -> Maybe a
forall a. Taggable a => Tagged -> Maybe a
from_tagged (Tagged -> Maybe a) -> Maybe Tagged -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context Tagged -> Maybe Tagged
forall val. Context val -> Maybe val
ctx_prev_val Context Tagged
ctx }

-- | A Call will be called as either a generator or a transformer, depending on
-- its position.  A call at the end of a compose pipeline will be called as
-- a generator while ones composed with it will be called as transformers, so
-- in @a | b@, @a@ is a transformer and @b@ is a generator.
--
-- More details on this strange setup are in the "Derive.Call" haddock.
data Call func = Call {
    forall func. Call func -> CallName
call_name :: !CallName
    , forall func. Call func -> CallDoc
call_doc :: !CallDoc
    , forall func. Call func -> func
call_func :: !func
    }
type Generator d = Call (GeneratorFunc d)
type Transformer d = Call (TransformerF d)

instance Show (Call d) where
    show :: Call d -> String
show Call d
call = String
"((Call " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallName -> String
forall a. Show a => a -> String
show (Call d -> CallName
forall func. Call func -> CallName
call_name Call d
call) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"))"
instance Pretty (Call d) where
    pretty :: Call d -> Text
pretty = CallName -> Text
forall a. Pretty a => a -> Text
pretty (CallName -> Text) -> (Call d -> CallName) -> Call d -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Call d -> CallName
forall func. Call func -> CallName
call_name

{- | Each call has an intrinsic name.  Since call IDs may be rebound
    dynamically, each call has its own name so that error msgs are unambiguous.
    It's also used along with 'ArgName' for argument defaulting, so if you want
    that to work it should be short and parseable by
    'Derive.Parse.p_unquoted_str'.  The name is not necessarily unique, and in
    fact may be intentionally non-unique to share defaults with another.

    The documentation for all calls that differ only in name are grouped
    together, so it's easier to read if small modifications are reflected in
    the name only.  If you put invalid identifiers in the name, it can't be
    used to set default arguments.
-}
newtype CallName = CallName Text
    deriving (CallName -> CallName -> Bool
(CallName -> CallName -> Bool)
-> (CallName -> CallName -> Bool) -> Eq CallName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallName -> CallName -> Bool
$c/= :: CallName -> CallName -> Bool
== :: CallName -> CallName -> Bool
$c== :: CallName -> CallName -> Bool
Eq, Eq CallName
Eq CallName
-> (CallName -> CallName -> Ordering)
-> (CallName -> CallName -> Bool)
-> (CallName -> CallName -> Bool)
-> (CallName -> CallName -> Bool)
-> (CallName -> CallName -> Bool)
-> (CallName -> CallName -> CallName)
-> (CallName -> CallName -> CallName)
-> Ord CallName
CallName -> CallName -> Bool
CallName -> CallName -> Ordering
CallName -> CallName -> CallName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CallName -> CallName -> CallName
$cmin :: CallName -> CallName -> CallName
max :: CallName -> CallName -> CallName
$cmax :: CallName -> CallName -> CallName
>= :: CallName -> CallName -> Bool
$c>= :: CallName -> CallName -> Bool
> :: CallName -> CallName -> Bool
$c> :: CallName -> CallName -> Bool
<= :: CallName -> CallName -> Bool
$c<= :: CallName -> CallName -> Bool
< :: CallName -> CallName -> Bool
$c< :: CallName -> CallName -> Bool
compare :: CallName -> CallName -> Ordering
$ccompare :: CallName -> CallName -> Ordering
Ord, Int -> CallName -> ShowS
[CallName] -> ShowS
CallName -> String
(Int -> CallName -> ShowS)
-> (CallName -> String) -> ([CallName] -> ShowS) -> Show CallName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallName] -> ShowS
$cshowList :: [CallName] -> ShowS
show :: CallName -> String
$cshow :: CallName -> String
showsPrec :: Int -> CallName -> ShowS
$cshowsPrec :: Int -> CallName -> ShowS
Show, [CallName] -> Doc
CallName -> Text
CallName -> Doc
(CallName -> Text)
-> (CallName -> Doc) -> ([CallName] -> Doc) -> Pretty CallName
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [CallName] -> Doc
$cformatList :: [CallName] -> Doc
format :: CallName -> Doc
$cformat :: CallName -> Doc
pretty :: CallName -> Text
$cpretty :: CallName -> Text
Pretty, String -> CallName
(String -> CallName) -> IsString CallName
forall a. (String -> a) -> IsString a
fromString :: String -> CallName
$cfromString :: String -> CallName
String.IsString)

-- | Each call argument has its own name, which is used for documentation as
-- well as argument defaulting, as documented in "Derive.Sig".
newtype ArgName = ArgName Text
    deriving (ArgName -> ArgName -> Bool
(ArgName -> ArgName -> Bool)
-> (ArgName -> ArgName -> Bool) -> Eq ArgName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgName -> ArgName -> Bool
$c/= :: ArgName -> ArgName -> Bool
== :: ArgName -> ArgName -> Bool
$c== :: ArgName -> ArgName -> Bool
Eq, Eq ArgName
Eq ArgName
-> (ArgName -> ArgName -> Ordering)
-> (ArgName -> ArgName -> Bool)
-> (ArgName -> ArgName -> Bool)
-> (ArgName -> ArgName -> Bool)
-> (ArgName -> ArgName -> Bool)
-> (ArgName -> ArgName -> ArgName)
-> (ArgName -> ArgName -> ArgName)
-> Ord ArgName
ArgName -> ArgName -> Bool
ArgName -> ArgName -> Ordering
ArgName -> ArgName -> ArgName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArgName -> ArgName -> ArgName
$cmin :: ArgName -> ArgName -> ArgName
max :: ArgName -> ArgName -> ArgName
$cmax :: ArgName -> ArgName -> ArgName
>= :: ArgName -> ArgName -> Bool
$c>= :: ArgName -> ArgName -> Bool
> :: ArgName -> ArgName -> Bool
$c> :: ArgName -> ArgName -> Bool
<= :: ArgName -> ArgName -> Bool
$c<= :: ArgName -> ArgName -> Bool
< :: ArgName -> ArgName -> Bool
$c< :: ArgName -> ArgName -> Bool
compare :: ArgName -> ArgName -> Ordering
$ccompare :: ArgName -> ArgName -> Ordering
Ord, Int -> ArgName -> ShowS
[ArgName] -> ShowS
ArgName -> String
(Int -> ArgName -> ShowS)
-> (ArgName -> String) -> ([ArgName] -> ShowS) -> Show ArgName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArgName] -> ShowS
$cshowList :: [ArgName] -> ShowS
show :: ArgName -> String
$cshow :: ArgName -> String
showsPrec :: Int -> ArgName -> ShowS
$cshowsPrec :: Int -> ArgName -> ShowS
Show, [ArgName] -> Doc
ArgName -> Text
ArgName -> Doc
(ArgName -> Text)
-> (ArgName -> Doc) -> ([ArgName] -> Doc) -> Pretty ArgName
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [ArgName] -> Doc
$cformatList :: [ArgName] -> Doc
format :: ArgName -> Doc
$cformat :: ArgName -> Doc
pretty :: ArgName -> Text
$cpretty :: ArgName -> Text
Pretty, String -> ArgName
(String -> ArgName) -> IsString ArgName
forall a. (String -> a) -> IsString a
fromString :: String -> ArgName
$cfromString :: String -> ArgName
String.IsString)

sym_to_call_name :: Expr.Symbol -> CallName
sym_to_call_name :: Symbol -> CallName
sym_to_call_name (Expr.Symbol Text
sym) = Text -> CallName
CallName Text
sym

str_to_call_name :: Expr.Str -> CallName
str_to_call_name :: Str -> CallName
str_to_call_name (Expr.Str Text
str) = Text -> CallName
CallName Text
str

str_to_arg_name :: Expr.Str -> ArgName
str_to_arg_name :: Str -> ArgName
str_to_arg_name (Expr.Str Text
str) = Text -> ArgName
ArgName Text
str

-- | Documentation for a call.  The documentation is in markdown format, except
-- that a single newline will be replaced with two, so a single \n is enough
-- to start a new paragraph.  Also, single quotes are turned into links as per
-- "Util.Texts".haddockUrl.
data CallDoc = CallDoc {
    CallDoc -> Module
cdoc_module :: !Module.Module
    , CallDoc -> Tags
cdoc_tags :: !Tags.Tags
    , CallDoc -> Doc
cdoc_doc :: !Doc.Doc
    , CallDoc -> [ArgDoc]
cdoc_args :: ![ArgDoc]
    } deriving (CallDoc -> CallDoc -> Bool
(CallDoc -> CallDoc -> Bool)
-> (CallDoc -> CallDoc -> Bool) -> Eq CallDoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallDoc -> CallDoc -> Bool
$c/= :: CallDoc -> CallDoc -> Bool
== :: CallDoc -> CallDoc -> Bool
$c== :: CallDoc -> CallDoc -> Bool
Eq, Eq CallDoc
Eq CallDoc
-> (CallDoc -> CallDoc -> Ordering)
-> (CallDoc -> CallDoc -> Bool)
-> (CallDoc -> CallDoc -> Bool)
-> (CallDoc -> CallDoc -> Bool)
-> (CallDoc -> CallDoc -> Bool)
-> (CallDoc -> CallDoc -> CallDoc)
-> (CallDoc -> CallDoc -> CallDoc)
-> Ord CallDoc
CallDoc -> CallDoc -> Bool
CallDoc -> CallDoc -> Ordering
CallDoc -> CallDoc -> CallDoc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CallDoc -> CallDoc -> CallDoc
$cmin :: CallDoc -> CallDoc -> CallDoc
max :: CallDoc -> CallDoc -> CallDoc
$cmax :: CallDoc -> CallDoc -> CallDoc
>= :: CallDoc -> CallDoc -> Bool
$c>= :: CallDoc -> CallDoc -> Bool
> :: CallDoc -> CallDoc -> Bool
$c> :: CallDoc -> CallDoc -> Bool
<= :: CallDoc -> CallDoc -> Bool
$c<= :: CallDoc -> CallDoc -> Bool
< :: CallDoc -> CallDoc -> Bool
$c< :: CallDoc -> CallDoc -> Bool
compare :: CallDoc -> CallDoc -> Ordering
$ccompare :: CallDoc -> CallDoc -> Ordering
Ord, Int -> CallDoc -> ShowS
[CallDoc] -> ShowS
CallDoc -> String
(Int -> CallDoc -> ShowS)
-> (CallDoc -> String) -> ([CallDoc] -> ShowS) -> Show CallDoc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallDoc] -> ShowS
$cshowList :: [CallDoc] -> ShowS
show :: CallDoc -> String
$cshow :: CallDoc -> String
showsPrec :: Int -> CallDoc -> ShowS
$cshowsPrec :: Int -> CallDoc -> ShowS
Show)

data ArgDoc = ArgDoc {
    ArgDoc -> ArgName
arg_name :: !ArgName
    , ArgDoc -> Type
arg_type :: !ValType.Type
    , ArgDoc -> ArgParser
arg_parser :: !ArgParser
    , ArgDoc -> EnvironDefault
arg_environ_default :: !EnvironDefault
    , ArgDoc -> Doc
arg_doc :: !Doc.Doc
    } deriving (ArgDoc -> ArgDoc -> Bool
(ArgDoc -> ArgDoc -> Bool)
-> (ArgDoc -> ArgDoc -> Bool) -> Eq ArgDoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgDoc -> ArgDoc -> Bool
$c/= :: ArgDoc -> ArgDoc -> Bool
== :: ArgDoc -> ArgDoc -> Bool
$c== :: ArgDoc -> ArgDoc -> Bool
Eq, Eq ArgDoc
Eq ArgDoc
-> (ArgDoc -> ArgDoc -> Ordering)
-> (ArgDoc -> ArgDoc -> Bool)
-> (ArgDoc -> ArgDoc -> Bool)
-> (ArgDoc -> ArgDoc -> Bool)
-> (ArgDoc -> ArgDoc -> Bool)
-> (ArgDoc -> ArgDoc -> ArgDoc)
-> (ArgDoc -> ArgDoc -> ArgDoc)
-> Ord ArgDoc
ArgDoc -> ArgDoc -> Bool
ArgDoc -> ArgDoc -> Ordering
ArgDoc -> ArgDoc -> ArgDoc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArgDoc -> ArgDoc -> ArgDoc
$cmin :: ArgDoc -> ArgDoc -> ArgDoc
max :: ArgDoc -> ArgDoc -> ArgDoc
$cmax :: ArgDoc -> ArgDoc -> ArgDoc
>= :: ArgDoc -> ArgDoc -> Bool
$c>= :: ArgDoc -> ArgDoc -> Bool
> :: ArgDoc -> ArgDoc -> Bool
$c> :: ArgDoc -> ArgDoc -> Bool
<= :: ArgDoc -> ArgDoc -> Bool
$c<= :: ArgDoc -> ArgDoc -> Bool
< :: ArgDoc -> ArgDoc -> Bool
$c< :: ArgDoc -> ArgDoc -> Bool
compare :: ArgDoc -> ArgDoc -> Ordering
$ccompare :: ArgDoc -> ArgDoc -> Ordering
Ord, Int -> ArgDoc -> ShowS
[ArgDoc] -> ShowS
ArgDoc -> String
(Int -> ArgDoc -> ShowS)
-> (ArgDoc -> String) -> ([ArgDoc] -> ShowS) -> Show ArgDoc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArgDoc] -> ShowS
$cshowList :: [ArgDoc] -> ShowS
show :: ArgDoc -> String
$cshow :: ArgDoc -> String
showsPrec :: Int -> ArgDoc -> ShowS
$cshowsPrec :: Int -> ArgDoc -> ShowS
Show)

-- | These enumerate the different ways an argumnt can be parsed, and
-- correspond to parsers in "Derive.Sig".
data ArgParser = Required | Defaulted !Text | Optional !Text | Many | Many1
    | Environ !(Maybe Text)
    deriving (ArgParser -> ArgParser -> Bool
(ArgParser -> ArgParser -> Bool)
-> (ArgParser -> ArgParser -> Bool) -> Eq ArgParser
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgParser -> ArgParser -> Bool
$c/= :: ArgParser -> ArgParser -> Bool
== :: ArgParser -> ArgParser -> Bool
$c== :: ArgParser -> ArgParser -> Bool
Eq, Eq ArgParser
Eq ArgParser
-> (ArgParser -> ArgParser -> Ordering)
-> (ArgParser -> ArgParser -> Bool)
-> (ArgParser -> ArgParser -> Bool)
-> (ArgParser -> ArgParser -> Bool)
-> (ArgParser -> ArgParser -> Bool)
-> (ArgParser -> ArgParser -> ArgParser)
-> (ArgParser -> ArgParser -> ArgParser)
-> Ord ArgParser
ArgParser -> ArgParser -> Bool
ArgParser -> ArgParser -> Ordering
ArgParser -> ArgParser -> ArgParser
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArgParser -> ArgParser -> ArgParser
$cmin :: ArgParser -> ArgParser -> ArgParser
max :: ArgParser -> ArgParser -> ArgParser
$cmax :: ArgParser -> ArgParser -> ArgParser
>= :: ArgParser -> ArgParser -> Bool
$c>= :: ArgParser -> ArgParser -> Bool
> :: ArgParser -> ArgParser -> Bool
$c> :: ArgParser -> ArgParser -> Bool
<= :: ArgParser -> ArgParser -> Bool
$c<= :: ArgParser -> ArgParser -> Bool
< :: ArgParser -> ArgParser -> Bool
$c< :: ArgParser -> ArgParser -> Bool
compare :: ArgParser -> ArgParser -> Ordering
$ccompare :: ArgParser -> ArgParser -> Ordering
Ord, Int -> ArgParser -> ShowS
[ArgParser] -> ShowS
ArgParser -> String
(Int -> ArgParser -> ShowS)
-> (ArgParser -> String)
-> ([ArgParser] -> ShowS)
-> Show ArgParser
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArgParser] -> ShowS
$cshowList :: [ArgParser] -> ShowS
show :: ArgParser -> String
$cshow :: ArgParser -> String
showsPrec :: Int -> ArgParser -> ShowS
$cshowsPrec :: Int -> ArgParser -> ShowS
Show)

-- | This configures how an argument looks for a default in the environ.
data EnvironDefault =
    -- | Don't default from environ at all.
    None
    -- | Look for @callname-argname@.
    | Prefixed
    -- | Look for @argname@.  This is useful for generic parameters that
    -- should configure many calls simultaneously.
    | Unprefixed
    -- | First look for a prefixed key, then for an unprefixed one.
    | Both
    deriving (EnvironDefault -> EnvironDefault -> Bool
(EnvironDefault -> EnvironDefault -> Bool)
-> (EnvironDefault -> EnvironDefault -> Bool) -> Eq EnvironDefault
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EnvironDefault -> EnvironDefault -> Bool
$c/= :: EnvironDefault -> EnvironDefault -> Bool
== :: EnvironDefault -> EnvironDefault -> Bool
$c== :: EnvironDefault -> EnvironDefault -> Bool
Eq, Eq EnvironDefault
Eq EnvironDefault
-> (EnvironDefault -> EnvironDefault -> Ordering)
-> (EnvironDefault -> EnvironDefault -> Bool)
-> (EnvironDefault -> EnvironDefault -> Bool)
-> (EnvironDefault -> EnvironDefault -> Bool)
-> (EnvironDefault -> EnvironDefault -> Bool)
-> (EnvironDefault -> EnvironDefault -> EnvironDefault)
-> (EnvironDefault -> EnvironDefault -> EnvironDefault)
-> Ord EnvironDefault
EnvironDefault -> EnvironDefault -> Bool
EnvironDefault -> EnvironDefault -> Ordering
EnvironDefault -> EnvironDefault -> EnvironDefault
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EnvironDefault -> EnvironDefault -> EnvironDefault
$cmin :: EnvironDefault -> EnvironDefault -> EnvironDefault
max :: EnvironDefault -> EnvironDefault -> EnvironDefault
$cmax :: EnvironDefault -> EnvironDefault -> EnvironDefault
>= :: EnvironDefault -> EnvironDefault -> Bool
$c>= :: EnvironDefault -> EnvironDefault -> Bool
> :: EnvironDefault -> EnvironDefault -> Bool
$c> :: EnvironDefault -> EnvironDefault -> Bool
<= :: EnvironDefault -> EnvironDefault -> Bool
$c<= :: EnvironDefault -> EnvironDefault -> Bool
< :: EnvironDefault -> EnvironDefault -> Bool
$c< :: EnvironDefault -> EnvironDefault -> Bool
compare :: EnvironDefault -> EnvironDefault -> Ordering
$ccompare :: EnvironDefault -> EnvironDefault -> Ordering
Ord, Int -> EnvironDefault -> ShowS
[EnvironDefault] -> ShowS
EnvironDefault -> String
(Int -> EnvironDefault -> ShowS)
-> (EnvironDefault -> String)
-> ([EnvironDefault] -> ShowS)
-> Show EnvironDefault
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EnvironDefault] -> ShowS
$cshowList :: [EnvironDefault] -> ShowS
show :: EnvironDefault -> String
$cshow :: EnvironDefault -> String
showsPrec :: Int -> EnvironDefault -> ShowS
$cshowsPrec :: Int -> EnvironDefault -> ShowS
Show)

-- | A value annotated with argument docs.  This is returned by the functions
-- in "Derive.Sig", and accepted by the Call constructors here.
type WithArgDoc f = (f, [ArgDoc])

-- ** make calls

data GeneratorFunc d = GeneratorFunc {
    forall d. GeneratorFunc d -> GeneratorF d
gfunc_f :: !(GeneratorF d)
    -- | This gets the logical duration of this call.  'CallDuration' has
    -- details.
    , forall d.
GeneratorFunc d -> PassedArgs d -> Deriver (CallDuration ScoreTime)
gfunc_score_duration
        :: !(PassedArgs d -> Deriver (CallDuration ScoreTime))
    , forall d.
GeneratorFunc d -> PassedArgs d -> Deriver (CallDuration RealTime)
gfunc_real_duration :: !(PassedArgs d -> Deriver (CallDuration RealTime))
    }

type GeneratorF d = PassedArgs d -> Deriver (Stream.Stream d)

generator_func :: (PassedArgs d -> Deriver (Stream.Stream d)) -> GeneratorFunc d
generator_func :: forall d. (PassedArgs d -> Deriver (Stream d)) -> GeneratorFunc d
generator_func PassedArgs d -> Deriver (Stream d)
f = GeneratorFunc
    { gfunc_f :: PassedArgs d -> Deriver (Stream d)
gfunc_f = PassedArgs d -> Deriver (Stream d)
f
    , gfunc_score_duration :: PassedArgs d -> Deriver (CallDuration ScoreTime)
gfunc_score_duration = PassedArgs d -> Deriver (CallDuration ScoreTime)
forall d. PassedArgs d -> Deriver (CallDuration ScoreTime)
default_score_duration
    , gfunc_real_duration :: PassedArgs d -> Deriver (CallDuration RealTime)
gfunc_real_duration = PassedArgs d -> Deriver (CallDuration RealTime)
forall d. PassedArgs d -> Deriver (CallDuration RealTime)
default_real_duration
    }

-- | Most calls have the same logical duration as their event.
default_score_duration :: PassedArgs d -> Deriver (CallDuration ScoreTime)
default_score_duration :: forall d. PassedArgs d -> Deriver (CallDuration ScoreTime)
default_score_duration =
    CallDuration ScoreTime -> Deriver (CallDuration ScoreTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (CallDuration ScoreTime -> Deriver (CallDuration ScoreTime))
-> (PassedArgs d -> CallDuration ScoreTime)
-> PassedArgs d
-> Deriver (CallDuration ScoreTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> CallDuration ScoreTime
forall a. a -> CallDuration a
CallDuration (ScoreTime -> CallDuration ScoreTime)
-> (PassedArgs d -> ScoreTime)
-> PassedArgs d
-> CallDuration ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> ScoreTime
Event.duration (Event -> ScoreTime)
-> (PassedArgs d -> Event) -> PassedArgs d -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context d -> Event
forall val. Context val -> Event
ctx_event (Context d -> Event)
-> (PassedArgs d -> Context d) -> PassedArgs d -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs d -> Context d
forall val. PassedArgs val -> Context val
passed_ctx

default_real_duration :: PassedArgs d -> Deriver (CallDuration RealTime)
default_real_duration :: forall d. PassedArgs d -> Deriver (CallDuration RealTime)
default_real_duration PassedArgs d
args = RealTime -> CallDuration RealTime
forall a. a -> CallDuration a
CallDuration (RealTime -> CallDuration RealTime)
-> Deriver State Error RealTime -> Deriver (CallDuration RealTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ScoreTime -> Deriver State Error RealTime
score_to_real (Event -> ScoreTime
Event.duration (Event -> ScoreTime) -> Event -> ScoreTime
forall a b. (a -> b) -> a -> b
$ Context d -> Event
forall val. Context val -> Event
ctx_event (Context d -> Event) -> Context d -> Event
forall a b. (a -> b) -> a -> b
$ PassedArgs d -> Context d
forall val. PassedArgs val -> Context val
passed_ctx PassedArgs d
args)

-- | args -> deriver -> deriver
type TransformerF d = PassedArgs d -> Deriver (Stream.Stream d)
    -> Deriver (Stream.Stream d)

make_call :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
    -> WithArgDoc func -> Call func
make_call :: forall func.
Module -> CallName -> Tags -> Doc -> WithArgDoc func -> Call func
make_call Module
module_ CallName
name Tags
tags Doc
doc (func
func, [ArgDoc]
arg_docs) = Call
    { call_name :: CallName
call_name = CallName
name
    , call_doc :: CallDoc
call_doc = CallDoc
        { cdoc_module :: Module
cdoc_module = Module
module_
        , cdoc_tags :: Tags
cdoc_tags = Tags
tags
        , cdoc_doc :: Doc
cdoc_doc = Doc
doc
        , cdoc_args :: [ArgDoc]
cdoc_args = [ArgDoc]
arg_docs
        }
    , call_func :: func
call_func = func
func
    }

-- | Create a generator that expects a list of derived values (e.g. Score.Event
-- or Signal.Control), with no logs mixed in.  The result is wrapped in
-- LEvent.Event.
generator :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
    -> WithArgDoc (GeneratorF d) -> Generator d
generator :: forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
generator Module
module_ CallName
name Tags
tags Doc
doc (GeneratorF d
func, [ArgDoc]
arg_docs) =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorFunc d)
-> Call (GeneratorFunc d)
forall func.
Module -> CallName -> Tags -> Doc -> WithArgDoc func -> Call func
make_call Module
module_ CallName
name Tags
tags Doc
doc (GeneratorF d -> GeneratorFunc d
forall d. (PassedArgs d -> Deriver (Stream d)) -> GeneratorFunc d
generator_func GeneratorF d
func, [ArgDoc]
arg_docs)

-- | Make a generator from a function which returns events in sorted order.
-- TODO this just trusts that the events will be sorted.  Is there a safer way?
generator_events :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
    -> WithArgDoc (PassedArgs d -> Deriver [d]) -> Generator d
generator_events :: forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver [d])
-> Generator d
generator_events Module
module_ CallName
name Tags
tags Doc
doc (PassedArgs d -> Deriver [d]
func, [ArgDoc]
arg_docs) =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
generator Module
module_ CallName
name Tags
tags Doc
doc
        (([d] -> Stream d
forall a. [a] -> Stream a
Stream.from_sorted_events <$>) (Deriver [d] -> Deriver (Stream d))
-> (PassedArgs d -> Deriver [d]) -> GeneratorF d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs d -> Deriver [d]
func, [ArgDoc]
arg_docs)

-- | Since Signals themselves are collections, there's little reason for a
-- signal generator to return a Stream of events.  So wrap the generator result
-- in a Stream singleton.
--
-- TODO call this signal_generator?
generator1 :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
    -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d
generator1 :: forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
generator1 Module
module_ CallName
name Tags
tags Doc
doc (PassedArgs d -> Deriver d
func, [ArgDoc]
arg_docs) =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
generator Module
module_ CallName
name Tags
tags Doc
doc
        ((d -> Stream d
forall a. a -> Stream a
Stream.from_event <$>) (Deriver d -> Deriver (Stream d))
-> (PassedArgs d -> Deriver d) -> GeneratorF d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs d -> Deriver d
func, [ArgDoc]
arg_docs)

-- | Set the 'gfunc_score_duration' field to get ScoreTime CallDuration.
with_score_duration :: (PassedArgs d -> Deriver (CallDuration ScoreTime))
    -> Generator d -> Generator d
with_score_duration :: forall d.
(PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
with_score_duration PassedArgs d -> Deriver (CallDuration ScoreTime)
get Generator d
call = Generator d
call
    { call_func :: GeneratorFunc d
call_func = (Generator d -> GeneratorFunc d
forall func. Call func -> func
call_func Generator d
call) { gfunc_score_duration :: PassedArgs d -> Deriver (CallDuration ScoreTime)
gfunc_score_duration = PassedArgs d -> Deriver (CallDuration ScoreTime)
get } }

with_real_duration :: (PassedArgs d -> Deriver (CallDuration RealTime))
    -> Generator d -> Generator d
with_real_duration :: forall d.
(PassedArgs d -> Deriver (CallDuration RealTime))
-> Generator d -> Generator d
with_real_duration PassedArgs d -> Deriver (CallDuration RealTime)
get Generator d
call = Generator d
call
    { call_func :: GeneratorFunc d
call_func = (Generator d -> GeneratorFunc d
forall func. Call func -> func
call_func Generator d
call) { gfunc_real_duration :: PassedArgs d -> Deriver (CallDuration RealTime)
gfunc_real_duration = PassedArgs d -> Deriver (CallDuration RealTime)
get } }

-- ** transformer

-- | Just 'make_call' with a more specific signature.
transformer :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
    -> WithArgDoc (TransformerF d) -> Transformer d
transformer :: forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
transformer = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Call (TransformerF d)
forall func.
Module -> CallName -> Tags -> Doc -> WithArgDoc func -> Call func
make_call

-- ** val

data ValCall = ValCall {
    ValCall -> CallName
vcall_name :: !CallName
    , ValCall -> CallDoc
vcall_doc :: !CallDoc
    , ValCall -> PassedArgs Tagged -> Deriver Val
vcall_call :: PassedArgs Tagged -> Deriver DeriveT.Val
    }

instance Show ValCall where
    show :: ValCall -> String
show (ValCall CallName
name CallDoc
_ PassedArgs Tagged -> Deriver Val
_) = String
"((ValCall " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallName -> String
forall a. Show a => a -> String
show CallName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"))"

make_val_call :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
    -> WithArgDoc (PassedArgs Tagged -> Deriver DeriveT.Val) -> ValCall
make_val_call :: Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
make_val_call Module
module_ CallName
name Tags
tags Doc
doc (PassedArgs Tagged -> Deriver Val
call, [ArgDoc]
arg_docs) = ValCall
    { vcall_name :: CallName
vcall_name = CallName
name
    , vcall_doc :: CallDoc
vcall_doc = CallDoc
        { cdoc_module :: Module
cdoc_module = Module
module_
        , cdoc_tags :: Tags
cdoc_tags = Tags
tags
        , cdoc_doc :: Doc
cdoc_doc = Doc
doc
        , cdoc_args :: [ArgDoc]
cdoc_args = [ArgDoc]
arg_docs
        }
    , vcall_call :: PassedArgs Tagged -> Deriver Val
vcall_call = PassedArgs Tagged -> Deriver Val
call
    }


-- ** cache types

-- $cache_doc
-- The cache types are nominally exported from "Derive.Cache", but must be
-- defined here to avoid circular dependencies.

-- instead of a stack, this could be a tree of frames
newtype Cache = Cache (Map CacheKey Cached)
    deriving (NonEmpty Cache -> Cache
Cache -> Cache -> Cache
(Cache -> Cache -> Cache)
-> (NonEmpty Cache -> Cache)
-> (forall b. Integral b => b -> Cache -> Cache)
-> Semigroup Cache
forall b. Integral b => b -> Cache -> Cache
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Cache -> Cache
$cstimes :: forall b. Integral b => b -> Cache -> Cache
sconcat :: NonEmpty Cache -> Cache
$csconcat :: NonEmpty Cache -> Cache
<> :: Cache -> Cache -> Cache
$c<> :: Cache -> Cache -> Cache
Semigroup, Semigroup Cache
Cache
Semigroup Cache
-> Cache
-> (Cache -> Cache -> Cache)
-> ([Cache] -> Cache)
-> Monoid Cache
[Cache] -> Cache
Cache -> Cache -> Cache
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Cache] -> Cache
$cmconcat :: [Cache] -> Cache
mappend :: Cache -> Cache -> Cache
$cmappend :: Cache -> Cache -> Cache
mempty :: Cache
$cmempty :: Cache
Monoid, [Cache] -> Doc
Cache -> Text
Cache -> Doc
(Cache -> Text)
-> (Cache -> Doc) -> ([Cache] -> Doc) -> Pretty Cache
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [Cache] -> Doc
$cformatList :: [Cache] -> Doc
format :: Cache -> Doc
$cformat :: Cache -> Doc
pretty :: Cache -> Text
$cpretty :: Cache -> Text
Pretty, Cache -> ()
(Cache -> ()) -> NFData Cache
forall a. (a -> ()) -> NFData a
rnf :: Cache -> ()
$crnf :: Cache -> ()
DeepSeq.NFData)
    -- The monoid instance winds up being a left-biased union.  This is ok
    -- because merged caches shouldn't overlap anyway.

cache_size :: Cache -> Int
cache_size :: Cache -> Int
cache_size (Cache Map CacheKey Cached
c) = Map CacheKey Cached -> Int
forall k a. Map k a -> Int
Map.size Map CacheKey Cached
c

{- | Ideally, the cache would be keyed by all data that can affect derivation,
    which would mean all of 'Dynamic' and 'Threaded'.  Effectively a deriver is
    a function that takes 'State' as its input, and this would be memoizing
    that function.  But in practice, there's too much junk in there, so I have
    to do an approximation.

    The first approximation is the stack, which is a proxy for the things that
    are likely to affect derivation.  Different calls in the stack are likely
    to result in a different environment, or a different 'Stack.Region' likely
    means a different warp.  'Stack.Serial' attempts to ensure that multiple
    generators within a single event also have unique stacks.
-}
newtype CacheKey = CacheKey { CacheKey -> Stack
key_stack :: Stack.Stack }
    deriving (CacheKey -> CacheKey -> Bool
(CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool) -> Eq CacheKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheKey -> CacheKey -> Bool
$c/= :: CacheKey -> CacheKey -> Bool
== :: CacheKey -> CacheKey -> Bool
$c== :: CacheKey -> CacheKey -> Bool
Eq, Eq CacheKey
Eq CacheKey
-> (CacheKey -> CacheKey -> Ordering)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> CacheKey)
-> (CacheKey -> CacheKey -> CacheKey)
-> Ord CacheKey
CacheKey -> CacheKey -> Bool
CacheKey -> CacheKey -> Ordering
CacheKey -> CacheKey -> CacheKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CacheKey -> CacheKey -> CacheKey
$cmin :: CacheKey -> CacheKey -> CacheKey
max :: CacheKey -> CacheKey -> CacheKey
$cmax :: CacheKey -> CacheKey -> CacheKey
>= :: CacheKey -> CacheKey -> Bool
$c>= :: CacheKey -> CacheKey -> Bool
> :: CacheKey -> CacheKey -> Bool
$c> :: CacheKey -> CacheKey -> Bool
<= :: CacheKey -> CacheKey -> Bool
$c<= :: CacheKey -> CacheKey -> Bool
< :: CacheKey -> CacheKey -> Bool
$c< :: CacheKey -> CacheKey -> Bool
compare :: CacheKey -> CacheKey -> Ordering
$ccompare :: CacheKey -> CacheKey -> Ordering
Ord, Int -> CacheKey -> ShowS
[CacheKey] -> ShowS
CacheKey -> String
(Int -> CacheKey -> ShowS)
-> (CacheKey -> String) -> ([CacheKey] -> ShowS) -> Show CacheKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheKey] -> ShowS
$cshowList :: [CacheKey] -> ShowS
show :: CacheKey -> String
$cshow :: CacheKey -> String
showsPrec :: Int -> CacheKey -> ShowS
$cshowsPrec :: Int -> CacheKey -> ShowS
Show, CacheKey -> ()
(CacheKey -> ()) -> NFData CacheKey
forall a. (a -> ()) -> NFData a
rnf :: CacheKey -> ()
$crnf :: CacheKey -> ()
DeepSeq.NFData, [CacheKey] -> Doc
CacheKey -> Text
CacheKey -> Doc
(CacheKey -> Text)
-> (CacheKey -> Doc) -> ([CacheKey] -> Doc) -> Pretty CacheKey
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [CacheKey] -> Doc
$cformatList :: [CacheKey] -> Doc
format :: CacheKey -> Doc
$cformat :: CacheKey -> Doc
pretty :: CacheKey -> Text
$cpretty :: CacheKey -> Text
Pretty)

-- | When cache entries are invalidated by ScoreDamage, a marker is left in
-- their place.  This is just for a nicer log msg that can tell the difference
-- between never evaluated and damaged.
data Cached = Cached !CacheEntry | Invalid

instance Pretty Cached where
    format :: Cached -> Doc
format Cached
Invalid = Text -> Doc
Pretty.text Text
"Invalid"
    format (Cached CacheEntry
entry) = CacheEntry -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CacheEntry
entry

instance DeepSeq.NFData Cached where
    rnf :: Cached -> ()
rnf Cached
Invalid = ()
    rnf (Cached CacheEntry
entry) = CacheEntry -> ()
forall a. NFData a => a -> ()
rnf CacheEntry
entry

-- | Since an entire track is one type but will have many different calls of
-- different types, the deriver type division goes above the call type
-- division.
data CacheEntry =
    CachedEvents !(CallType Score.Event)
    | CachedControl !(CallType Signal.Control)
    | CachedPitch !(CallType PSignal.PSignal)

instance Pretty CacheEntry where
    format :: CacheEntry -> Doc
format (CachedEvents (CallType Collect
_ Stream Event
events)) = Stream Event -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stream Event
events
    format (CachedControl (CallType Collect
_ Stream Control
events)) = Stream Control -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stream Control
events
    format (CachedPitch (CallType Collect
_ Stream PSignal
events)) = Stream PSignal -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stream PSignal
events

instance DeepSeq.NFData CacheEntry where
    rnf :: CacheEntry -> ()
rnf (CachedEvents CallType Event
c) = CallType Event -> ()
forall a. NFData a => a -> ()
rnf CallType Event
c
    rnf (CachedControl CallType Control
c) = CallType Control -> ()
forall a. NFData a => a -> ()
rnf CallType Control
c
    rnf (CachedPitch CallType PSignal
c) = CallType PSignal -> ()
forall a. NFData a => a -> ()
rnf CallType PSignal
c

-- | The type here should match the type of the stack it's associated with,
-- but I'm not quite up to those type gymnastics yet.
data CallType d = CallType !Collect !(Stream.Stream d)

instance DeepSeq.NFData d => DeepSeq.NFData (CallType d) where
    rnf :: CallType d -> ()
rnf (CallType Collect
collect Stream d
events) = Collect -> ()
forall a. NFData a => a -> ()
rnf Collect
collect () -> () -> ()
`seq` Stream d -> ()
forall a. NFData a => a -> ()
rnf Stream d
events

-- ** deps

newtype BlockDeps = BlockDeps (Set BlockId)
    deriving ([BlockDeps] -> Doc
BlockDeps -> Text
BlockDeps -> Doc
(BlockDeps -> Text)
-> (BlockDeps -> Doc) -> ([BlockDeps] -> Doc) -> Pretty BlockDeps
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [BlockDeps] -> Doc
$cformatList :: [BlockDeps] -> Doc
format :: BlockDeps -> Doc
$cformat :: BlockDeps -> Doc
pretty :: BlockDeps -> Text
$cpretty :: BlockDeps -> Text
Pretty, NonEmpty BlockDeps -> BlockDeps
BlockDeps -> BlockDeps -> BlockDeps
(BlockDeps -> BlockDeps -> BlockDeps)
-> (NonEmpty BlockDeps -> BlockDeps)
-> (forall b. Integral b => b -> BlockDeps -> BlockDeps)
-> Semigroup BlockDeps
forall b. Integral b => b -> BlockDeps -> BlockDeps
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> BlockDeps -> BlockDeps
$cstimes :: forall b. Integral b => b -> BlockDeps -> BlockDeps
sconcat :: NonEmpty BlockDeps -> BlockDeps
$csconcat :: NonEmpty BlockDeps -> BlockDeps
<> :: BlockDeps -> BlockDeps -> BlockDeps
$c<> :: BlockDeps -> BlockDeps -> BlockDeps
Semigroup, Semigroup BlockDeps
BlockDeps
Semigroup BlockDeps
-> BlockDeps
-> (BlockDeps -> BlockDeps -> BlockDeps)
-> ([BlockDeps] -> BlockDeps)
-> Monoid BlockDeps
[BlockDeps] -> BlockDeps
BlockDeps -> BlockDeps -> BlockDeps
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [BlockDeps] -> BlockDeps
$cmconcat :: [BlockDeps] -> BlockDeps
mappend :: BlockDeps -> BlockDeps -> BlockDeps
$cmappend :: BlockDeps -> BlockDeps -> BlockDeps
mempty :: BlockDeps
$cmempty :: BlockDeps
Monoid, Int -> BlockDeps -> ShowS
[BlockDeps] -> ShowS
BlockDeps -> String
(Int -> BlockDeps -> ShowS)
-> (BlockDeps -> String)
-> ([BlockDeps] -> ShowS)
-> Show BlockDeps
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockDeps] -> ShowS
$cshowList :: [BlockDeps] -> ShowS
show :: BlockDeps -> String
$cshow :: BlockDeps -> String
showsPrec :: Int -> BlockDeps -> ShowS
$cshowsPrec :: Int -> BlockDeps -> ShowS
Show, BlockDeps -> BlockDeps -> Bool
(BlockDeps -> BlockDeps -> Bool)
-> (BlockDeps -> BlockDeps -> Bool) -> Eq BlockDeps
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockDeps -> BlockDeps -> Bool
$c/= :: BlockDeps -> BlockDeps -> Bool
== :: BlockDeps -> BlockDeps -> Bool
$c== :: BlockDeps -> BlockDeps -> Bool
Eq, BlockDeps -> ()
(BlockDeps -> ()) -> NFData BlockDeps
forall a. (a -> ()) -> NFData a
rnf :: BlockDeps -> ()
$crnf :: BlockDeps -> ()
DeepSeq.NFData)

-- ** damage

-- | Modified ranges in the score.
data ScoreDamage = ScoreDamage {
    -- | Damaged ranges in tracks.
    ScoreDamage -> Map TrackId (Ranges ScoreTime)
sdamage_tracks :: !(Map TrackId (Ranges.Ranges ScoreTime))
    -- | The blocks with damaged tracks.  Calls depend on blocks
    -- ('BlockDeps') rather than tracks, so it's convenient to keep the
    -- blocks here.  This is different than block damage because a damaged
    -- block will invalidate all caches below it, but a block with damaged
    -- tracks must be called but may still have valid caches within.
    , ScoreDamage -> Set BlockId
sdamage_track_blocks :: !(Set BlockId)
    -- | Blocks which are entirely damaged.
    , ScoreDamage -> Set BlockId
sdamage_blocks :: !(Set BlockId)
    } deriving (ScoreDamage -> ScoreDamage -> Bool
(ScoreDamage -> ScoreDamage -> Bool)
-> (ScoreDamage -> ScoreDamage -> Bool) -> Eq ScoreDamage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScoreDamage -> ScoreDamage -> Bool
$c/= :: ScoreDamage -> ScoreDamage -> Bool
== :: ScoreDamage -> ScoreDamage -> Bool
$c== :: ScoreDamage -> ScoreDamage -> Bool
Eq, Int -> ScoreDamage -> ShowS
[ScoreDamage] -> ShowS
ScoreDamage -> String
(Int -> ScoreDamage -> ShowS)
-> (ScoreDamage -> String)
-> ([ScoreDamage] -> ShowS)
-> Show ScoreDamage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScoreDamage] -> ShowS
$cshowList :: [ScoreDamage] -> ShowS
show :: ScoreDamage -> String
$cshow :: ScoreDamage -> String
showsPrec :: Int -> ScoreDamage -> ShowS
$cshowsPrec :: Int -> ScoreDamage -> ShowS
Show)

instance Semigroup ScoreDamage where
    <> :: ScoreDamage -> ScoreDamage -> ScoreDamage
(<>)    (ScoreDamage Map TrackId (Ranges ScoreTime)
tracks1 Set BlockId
tblocks1 Set BlockId
blocks1)
            (ScoreDamage Map TrackId (Ranges ScoreTime)
tracks2 Set BlockId
tblocks2 Set BlockId
blocks2) =
        Map TrackId (Ranges ScoreTime)
-> Set BlockId -> Set BlockId -> ScoreDamage
ScoreDamage (Map TrackId (Ranges ScoreTime)
-> Map TrackId (Ranges ScoreTime) -> Map TrackId (Ranges ScoreTime)
forall k a. (Ord k, Monoid a) => Map k a -> Map k a -> Map k a
Maps.mappend Map TrackId (Ranges ScoreTime)
tracks1 Map TrackId (Ranges ScoreTime)
tracks2)
            (Set BlockId
tblocks1 Set BlockId -> Set BlockId -> Set BlockId
forall a. Semigroup a => a -> a -> a
<> Set BlockId
tblocks2) (Set BlockId
blocks1 Set BlockId -> Set BlockId -> Set BlockId
forall a. Semigroup a => a -> a -> a
<> Set BlockId
blocks2)
instance Monoid ScoreDamage where
    mempty :: ScoreDamage
mempty = Map TrackId (Ranges ScoreTime)
-> Set BlockId -> Set BlockId -> ScoreDamage
ScoreDamage Map TrackId (Ranges ScoreTime)
forall k a. Map k a
Map.empty Set BlockId
forall a. Set a
Set.empty Set BlockId
forall a. Set a
Set.empty
    mappend :: ScoreDamage -> ScoreDamage -> ScoreDamage
mappend = ScoreDamage -> ScoreDamage -> ScoreDamage
forall a. Semigroup a => a -> a -> a
(<>)

instance Pretty ScoreDamage where
    format :: ScoreDamage -> Doc
format (ScoreDamage Map TrackId (Ranges ScoreTime)
tracks Set BlockId
track_blocks Set BlockId
blocks) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"ScoreDamage"
            [ (Text
"tracks", Map TrackId (Ranges ScoreTime) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map TrackId (Ranges ScoreTime)
tracks)
            , (Text
"track_blocks", Set BlockId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Set BlockId
track_blocks)
            , (Text
"blocks", Set BlockId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Set BlockId
blocks)
            ]

instance DeepSeq.NFData ScoreDamage where
    rnf :: ScoreDamage -> ()
rnf (ScoreDamage Map TrackId (Ranges ScoreTime)
tracks Set BlockId
track_blocks Set BlockId
blocks) =
        Map TrackId (Ranges ScoreTime) -> ()
forall a. NFData a => a -> ()
rnf Map TrackId (Ranges ScoreTime)
tracks () -> () -> ()
`seq` Set BlockId -> ()
forall a. NFData a => a -> ()
rnf Set BlockId
track_blocks () -> () -> ()
`seq` Set BlockId -> ()
forall a. NFData a => a -> ()
rnf Set BlockId
blocks

-- | Clear the damaged portions out of the cache so they will rederive.
--
-- Block damage also clears track caches that are on that block.
invalidate_damaged :: ScoreDamage -> Cache -> Cache
invalidate_damaged :: ScoreDamage -> Cache -> Cache
invalidate_damaged (ScoreDamage Map TrackId (Ranges ScoreTime)
tracks Set BlockId
_ Set BlockId
blocks) (Cache Map CacheKey Cached
cache) =
    Map CacheKey Cached -> Cache
Cache (Map CacheKey Cached -> Cache) -> Map CacheKey Cached -> Cache
forall a b. (a -> b) -> a -> b
$ (CacheKey -> Cached -> Cached)
-> Map CacheKey Cached -> Map CacheKey Cached
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey CacheKey -> Cached -> Cached
invalidate (Map CacheKey Cached -> Map CacheKey Cached)
-> Map CacheKey Cached -> Map CacheKey Cached
forall a b. (a -> b) -> a -> b
$ (Cached -> Bool) -> Map CacheKey Cached -> Map CacheKey Cached
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Cached -> Bool
is_valid Map CacheKey Cached
cache
    where
    is_valid :: Cached -> Bool
is_valid Cached
Invalid = Bool
False
    is_valid Cached
_ = Bool
True
    invalidate :: CacheKey -> Cached -> Cached
invalidate CacheKey
key Cached
cached
        | Stack -> Bool
has_damage (CacheKey -> Stack
key_stack CacheKey
key) = Cached
Invalid
        | Bool
otherwise = Cached
cached
    has_damage :: Stack -> Bool
has_damage Stack
stack = ((Maybe BlockId, Maybe TrackId, Maybe (ScoreTime, ScoreTime))
 -> Bool)
-> [(Maybe BlockId, Maybe TrackId, Maybe (ScoreTime, ScoreTime))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe BlockId, Maybe TrackId, Maybe (ScoreTime, ScoreTime))
-> Bool
overlaps (Stack
-> [(Maybe BlockId, Maybe TrackId, Maybe (ScoreTime, ScoreTime))]
Stack.to_ui_innermost Stack
stack)
    overlaps :: (Maybe BlockId, Maybe TrackId, Maybe (ScoreTime, ScoreTime))
-> Bool
overlaps (Maybe BlockId
block, Maybe TrackId
track, Maybe (ScoreTime, ScoreTime)
range) = Bool -> (BlockId -> Bool) -> Maybe BlockId -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (BlockId -> Set BlockId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BlockId
blocks) Maybe BlockId
block
        Bool -> Bool -> Bool
|| case (Maybe TrackId
track, Maybe (ScoreTime, ScoreTime)
range) of
            (Just TrackId
track_id, Maybe (ScoreTime, ScoreTime)
Nothing) -> TrackId -> Map TrackId (Ranges ScoreTime) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TrackId
track_id Map TrackId (Ranges ScoreTime)
tracks
            (Just TrackId
track_id, Just (ScoreTime
s, ScoreTime
e))
                | Just Ranges ScoreTime
ranges <- TrackId
-> Map TrackId (Ranges ScoreTime) -> Maybe (Ranges ScoreTime)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
track_id Map TrackId (Ranges ScoreTime)
tracks ->
                    Ranges ScoreTime -> Ranges ScoreTime -> Bool
forall n. Ord n => Ranges n -> Ranges n -> Bool
Ranges.overlapping Ranges ScoreTime
ranges (ScoreTime -> ScoreTime -> Ranges ScoreTime
forall n. n -> n -> Ranges n
Ranges.range ScoreTime
s ScoreTime
e)
            (Maybe TrackId, Maybe (ScoreTime, ScoreTime))
_ -> Bool
False

-- | Control damage indicates that a section of control signal has been
-- modified.  It's dynamically scoped over the same range as the control
-- itself, so that events that depend on it can be rederived.
newtype ControlDamage = ControlDamage (Ranges.Ranges ScoreTime)
    deriving ([ControlDamage] -> Doc
ControlDamage -> Text
ControlDamage -> Doc
(ControlDamage -> Text)
-> (ControlDamage -> Doc)
-> ([ControlDamage] -> Doc)
-> Pretty ControlDamage
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [ControlDamage] -> Doc
$cformatList :: [ControlDamage] -> Doc
format :: ControlDamage -> Doc
$cformat :: ControlDamage -> Doc
pretty :: ControlDamage -> Text
$cpretty :: ControlDamage -> Text
Pretty, NonEmpty ControlDamage -> ControlDamage
ControlDamage -> ControlDamage -> ControlDamage
(ControlDamage -> ControlDamage -> ControlDamage)
-> (NonEmpty ControlDamage -> ControlDamage)
-> (forall b. Integral b => b -> ControlDamage -> ControlDamage)
-> Semigroup ControlDamage
forall b. Integral b => b -> ControlDamage -> ControlDamage
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> ControlDamage -> ControlDamage
$cstimes :: forall b. Integral b => b -> ControlDamage -> ControlDamage
sconcat :: NonEmpty ControlDamage -> ControlDamage
$csconcat :: NonEmpty ControlDamage -> ControlDamage
<> :: ControlDamage -> ControlDamage -> ControlDamage
$c<> :: ControlDamage -> ControlDamage -> ControlDamage
Semigroup, Semigroup ControlDamage
ControlDamage
Semigroup ControlDamage
-> ControlDamage
-> (ControlDamage -> ControlDamage -> ControlDamage)
-> ([ControlDamage] -> ControlDamage)
-> Monoid ControlDamage
[ControlDamage] -> ControlDamage
ControlDamage -> ControlDamage -> ControlDamage
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ControlDamage] -> ControlDamage
$cmconcat :: [ControlDamage] -> ControlDamage
mappend :: ControlDamage -> ControlDamage -> ControlDamage
$cmappend :: ControlDamage -> ControlDamage -> ControlDamage
mempty :: ControlDamage
$cmempty :: ControlDamage
Monoid, ControlDamage -> ControlDamage -> Bool
(ControlDamage -> ControlDamage -> Bool)
-> (ControlDamage -> ControlDamage -> Bool) -> Eq ControlDamage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ControlDamage -> ControlDamage -> Bool
$c/= :: ControlDamage -> ControlDamage -> Bool
== :: ControlDamage -> ControlDamage -> Bool
$c== :: ControlDamage -> ControlDamage -> Bool
Eq, Int -> ControlDamage -> ShowS
[ControlDamage] -> ShowS
ControlDamage -> String
(Int -> ControlDamage -> ShowS)
-> (ControlDamage -> String)
-> ([ControlDamage] -> ShowS)
-> Show ControlDamage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlDamage] -> ShowS
$cshowList :: [ControlDamage] -> ShowS
show :: ControlDamage -> String
$cshow :: ControlDamage -> String
showsPrec :: Int -> ControlDamage -> ShowS
$cshowsPrec :: Int -> ControlDamage -> ShowS
Show, ControlDamage -> ()
(ControlDamage -> ()) -> NFData ControlDamage
forall a. (a -> ()) -> NFData a
rnf :: ControlDamage -> ()
$crnf :: ControlDamage -> ()
DeepSeq.NFData)

-- * util

{-# SCC score_to_real #-}
score_to_real :: ScoreTime -> Deriver RealTime
score_to_real :: ScoreTime -> Deriver State Error RealTime
score_to_real ScoreTime
pos = do
    Warp
warp <- (State -> Warp) -> Deriver State Error Warp
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Warp
state_warp (Dynamic -> Warp) -> (State -> Dynamic) -> State -> Warp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
    RealTime -> Deriver State Error RealTime
forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime -> Deriver State Error RealTime)
-> RealTime -> Deriver State Error RealTime
forall a b. (a -> b) -> a -> b
$ Warp -> ScoreTime -> RealTime
Warp.warp Warp
warp ScoreTime
pos

{-# SCC real_to_score #-}
real_to_score :: RealTime -> Deriver ScoreTime
real_to_score :: RealTime -> Deriver ScoreTime
real_to_score RealTime
pos = do
    Warp
warp <- (State -> Warp) -> Deriver State Error Warp
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Warp
state_warp (Dynamic -> Warp) -> (State -> Dynamic) -> State -> Warp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
    ScoreTime -> Deriver ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ScoreTime -> Deriver ScoreTime) -> ScoreTime -> Deriver ScoreTime
forall a b. (a -> b) -> a -> b
$ Warp -> RealTime -> ScoreTime
Warp.unwarp Warp
warp RealTime
pos


-- * scale

-- Like the cache types, this is supposed to be defined in "Derive.Scale", but
-- must be here due to circular dependencies.

data Scale = Scale {
    Scale -> ScaleId
scale_id :: !Pitch.ScaleId
    -- | A pattern describing what the scale notes look like.  Used only for
    -- error msgs (i.e. parse errors) so it should be human readable and
    -- doesn't have to follow any particular syntax.  A regex is recommended
    -- though.
    , Scale -> Text
scale_pattern :: !Text

    -- | If a scale uses 'Symbol.Symbol's, it can include the definitions here
    -- so they are close to their use.  This symbol list should be loaded as
    -- soon as possible, which means program startup for hardcoded scales.
    , Scale -> [Symbol]
scale_symbols :: ![Symbol.Symbol]

    -- | The controls that will casue a pitch from this scale to change.
    -- This is used by 'PSignal.apply_controls' to know when to reevaluate
    -- a given pitch.  Other controls can affect the pitch, but if they aren't
    -- in this set, the pitch won't be reevaluated when they change.
    , Scale -> Set Control
scale_transposers :: !(Set ScoreT.Control)
    -- | Parse a Note into a Pitch.Pitch with scale degree and accidentals.
    , Scale -> Environ -> Note -> Either PitchError Pitch
scale_read :: DeriveT.Environ -> Pitch.Note
        -> Either DeriveT.PitchError Pitch.Pitch
    , Scale -> Environ -> Pitch -> Either PitchError Note
scale_show :: DeriveT.Environ -> Pitch.Pitch
        -> Either DeriveT.PitchError Pitch.Note
    -- | Bottom pitch of the scale, if there is one.  You can find the top
    -- pitch by transposing until you get OutOfRange.  TODO that's a dumb way,
    -- if I explicitly need the top I should just add it.
    , Scale -> Pitch
scale_bottom :: !Pitch.Pitch
    -- | If a scale has a Layout, cmds can do math with 'Pitch.Pitch'es.
    , Scale -> Layout
scale_layout :: !Layout
    , Scale -> Transpose
scale_transpose :: !Transpose
    , Scale -> Enharmonics
scale_enharmonics :: !Enharmonics

    -- | Used by derivation.
    , Scale -> Note -> Maybe ValCall
scale_note_to_call :: !(Pitch.Note -> Maybe ValCall)

    -- | Used by note input.
    , Scale -> Environ -> Input -> Either PitchError Note
scale_input_to_note :: !(DeriveT.Environ -> Pitch.Input
        -> Either DeriveT.PitchError Pitch.Note)
    -- | Used by MIDI thru.  This is a shortcut for
    -- @eval . note_to_call . input_to_note@ but can often be implemented more
    -- efficiently by the scale.
    --
    -- The ScoreTime is the time at which this pitch is evaluated.  If it
    -- depends on a control, it can get the control from 'Dynamic', but it
    -- needs to know at what point in time to look at the signal.
    --
    -- This is because pitch val calls aren't evaluated in normalized time.
    -- If controls had (shift, stretch) I could normalize them efficiently
    -- and the pitch would just always look at time 0.  But they don't.
    , Scale
-> ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
scale_input_to_nn :: !(ScoreTime -> Pitch.Input
        -> Deriver (Either DeriveT.PitchError Pitch.NoteNumber))

    -- | Documentation for all of the ValCalls that 'scale_note_to_call' can
    -- return.
    , Scale -> DocumentedCall
scale_call_doc :: !DocumentedCall
    }

instance Pretty Scale where
    pretty :: Scale -> Text
pretty = ScaleId -> Text
forall a. Pretty a => a -> Text
pretty (ScaleId -> Text) -> (Scale -> ScaleId) -> Scale -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> ScaleId
scale_id

-- | A scale can configure itself by looking in the environment and by looking
-- up other scales.
newtype LookupScale = LookupScale (DeriveT.Environ
    -> Pitch.ScaleId -> Maybe (Either DeriveT.PitchError Scale))
instance Show LookupScale where show :: LookupScale -> String
show LookupScale
_ = String
"((LookupScale))"

-- | Scales may ignore Transposition if they don't support it.
--
-- Transposition could almost always succeed, and leaving the error reporting
-- to 'scale_show'.  But for some scales it has to parse the 'Pitch.Key' from
-- the environ, which can fail.  Parsing the key is pretty unfortunate, since
-- it winds up getting repeated for 'scale_read' and 'scale_show', but I don't
-- want to make the Key type concrete, since each scale has a different one.
--
-- TODO could make the key an existential type and export scale_parse_key?
type Transpose = Transposition -> DeriveT.Environ -> Pitch.Step -> Pitch.Pitch
    -> Either DeriveT.PitchError Pitch.Pitch

data Transposition = Chromatic | Diatonic deriving (Int -> Transposition -> ShowS
[Transposition] -> ShowS
Transposition -> String
(Int -> Transposition -> ShowS)
-> (Transposition -> String)
-> ([Transposition] -> ShowS)
-> Show Transposition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Transposition] -> ShowS
$cshowList :: [Transposition] -> ShowS
show :: Transposition -> String
$cshow :: Transposition -> String
showsPrec :: Int -> Transposition -> ShowS
$cshowsPrec :: Int -> Transposition -> ShowS
Show)

-- | Get the enharmonics of the note.  The given note is omitted, and the
-- enharmonics are in ascending order until they wrap around, so if you always
-- take the head of the list you will cycle through all of the enharmonics.
type Enharmonics = DeriveT.Environ -> Pitch.Note
    -> Either DeriveT.PitchError [Pitch.Note]

-- | The number of chromatic intervals between each 'Pitch.PitchClass',
-- starting from 0, as returned by 'scale_read'.  The length is the number of
-- degrees per octave.  A diatonic-only scale will have all 1s, and a scale
-- without octaves has an empty layout.
--
-- This is analogous to 'Theory.Layout', but is intended to be a minimal
-- implementation that all scales can export, without having to support the
-- full complexity of a chromatic scale.
--
-- Combined with 'scale_read' and 'scale_show', I can use this to do math on
-- scale degrees.
type Layout = Vector.Unboxed.Vector Pitch.Semi

-- * merge

-- | Merge the events of the given derivers.
d_merge :: [NoteDeriver] -> NoteDeriver
d_merge :: [NoteDeriver] -> NoteDeriver
d_merge [] = NoteDeriver
forall a. Monoid a => a
mempty
d_merge [NoteDeriver
d] = NoteDeriver
d
d_merge [NoteDeriver]
derivers = [Stream Event] -> Stream Event
forall a. Monoid a => [a] -> a
mconcat ([Stream Event] -> Stream Event)
-> Deriver State Error [Stream Event] -> NoteDeriver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NoteDeriver] -> Deriver State Error [Stream Event]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [NoteDeriver]
derivers
    -- mconcat on Stream should keep them sorted.
    -- Previously, each deriver was run independently, and their Collects
    -- merged.  The theory was to allow their derivation to be interleaved
    -- on demand as the events themselves are interleaved.  However, profiling
    -- doesn't show a significant difference, and this way is simpler.

merge_logs :: Either Error (Stream.Stream a) -> [Log.Msg] -> Stream.Stream a
merge_logs :: forall a. Either Error (Stream a) -> [Msg] -> Stream a
merge_logs Either Error (Stream a)
result [Msg]
logs = case Either Error (Stream a)
result of
    Right Stream a
stream -> [Msg] -> Stream a -> Stream a
forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs [Msg]
logs Stream a
stream
    Left Error
err -> [Msg] -> Stream a
forall a. [Msg] -> Stream a
Stream.from_logs ([Msg] -> Stream a) -> [Msg] -> Stream a
forall a b. (a -> b) -> a -> b
$ Error -> Msg
error_to_warn Error
err Msg -> [Msg] -> [Msg]
forall a. a -> [a] -> [a]
: [Msg]
logs

error_to_warn :: Error -> Log.Msg
error_to_warn :: Error -> Msg
error_to_warn (Error CallStack
call_stack Stack
stack ErrorVal
error_val) =
    CallStack -> Priority -> Maybe Stack -> Text -> Msg
Log.msg_call_stack CallStack
call_stack Priority
Log.Warn (Stack -> Maybe Stack
forall a. a -> Maybe a
Just Stack
stack) (ErrorVal -> Text
forall a. Pretty a => a -> Text
pretty ErrorVal
error_val)

{- NOTE [control-modification]
    . Control tracks return a single control, and how that merges into the
      environ is up to the track.
    . It would be convenient to do it in an existing track, e.g. the pitch
      track, and not have to add a whole new track just for a few fancy
      ornaments.  The pitch track is a natural choice, but if it's going to
      modify other controls it should be beneath them, right?  The pitch track
      is on top, not for a good reason, but just because it's next to the note
      track.  I could solve this by reversing the order of the skeleton, at
      the cost of it looking a little weird.
    . However, once I'm doing this, why is the pitch track special?  Why
      wouldn't I want to have calls that affect multiple non-pitch controls?
    . The note track seems like a natural place for this stuff, but that would
      require some notion of a non-note event within a note event.  But that
      means either sub-event text, which seems like a giant increase in
      complexity, or some awful hack like e.g. events starting with ';' are
      merged into the non-; note event, and somehow evaluated with it.
      Besides, this doesn't compose nicely, what if I want multiple high-level
      control tracks at once?
    / Generalize control tracks to return
      'Either (Name, PSignal) (Name, ControlSignal, Merger).
      The track call splits them apart, and merges into the environ.  This
      would make pitch tracks and control tracks the same, just a different
      default.  But that's no good because they already have separate
      namespaces, which are very useful.
    * Control calls and pitch calls can emit "control modifications", which
      are (control, signal) pairs that will be multiplied with the environ.
      Each one is an entire signal.  Since the signals are combined with
      multiplication, it doesn't matter what order they go in.  The
      modifications can go in Collect.
      Pitch modification has to transposition, but it would have to use a
      transpose signal.  However, transpose signals are additive, not
      multiplicative.  So I need some way to indicate the combining operator
      after all.
-}

{- NOTE [call-duration]
    This is containued from 'CallDuration'.

    Initially I used just Collect, and each deriver could put a CallDuration
    into Collect.  Unfortunately this means I have to run the whole deriver and
    evaluate all the notes.  I tried to exploit laziness a bit, but it's
    probably impossible.  In addition, merging durations is not correct, because
    the duration set by the block call should override the durations set by
    the events inside.

    Then I tried splitting Deriver into (DeriveM, CallDuration) and merging
    CallDurations in the Applicative instance.  This prevents evaluation, but
    stops propagating the CallDurations as soon as it hits a (>>=).  This turns
    out to be pretty much immediately, since an event call needs to parse text
    and look up a call, which can throw.  The underlying reason is that
    I actually do need to evaluate a certain amount of the deriver to figure out
    what kind of deriver it is.

    Since the things that have CallDuration are not so much any old deriver,
    but specifically calls, I tried putting a special field in 'Generator'
    calls, which turned out to work.
-}

{- NOTE [event-serial]
    Here are the notes leading up to the current implementation of
    'state_event_serial':

    Kilitan notes all have the same random seed, so randomizing start
    offsets moves them all the same amount.  Multiple notes generated by
    the same call should have unique stacks so they have have different
    seeds.
    . I could do it manually by having a ID number argument to the various
      create note calls, e.g. Call.note and callers.  This would rely on
      manually keeping the ID number.
    . Or automatically with a per-call serial number in Derive.Threaded.
      It would be ok to reset it as soon as the call changed, because then
      the stack has changed.  But anyone who makes a note, e.g. Call.note,
      will have to get and increment it.
    . Each note should have a unique stack, which means that multiple
      Score.Events created by a single call need something on the end to make
      them unique.  But how do I define a "single note"?  Even the "" call
      could create multiple Score.Events.  I could put the increment in
      the note call itself, but I need to make sure I reset the ID.
    . But where to reset?  All of Threaded is reset per-track, though perhaps
      it actually isn't.  But the reason to reset is to distinguish events
      with the same stack.  So it should be reset when the stack is popped,
      but I don't think that's an explicit thing, just using the old state.
      I could make Derive.local reset the serial on every old state, but that
      sounds slow as well as being in the wrong place.
    . If I reset on every call, then I will reset on block calls that make
      lots of notes, but it's ok because I'll reset again on each note call.
      So I can reset whenever I add a Stack.Call.
    . Actually that's no good, because when I call note multiple times it adds
      the same Stack.Call "note" each time.  Maybe I only reset when setting
      Region?  Of course any evaluation may be inverting, so it may add any
      number of new stack entries.  It's just that they will happen to be
      identical.
    . Really I want to say if I've seen this stack before, then append
      something to make it unique.  But that sounds really expensive.  Or
      really?  What if I had a set of seeds, and I check it for duplicates
      on each note?  Every event in the track eval could reset it, so it
      wouldn't get too large.  But how again is that different from just
      incrementing the serial in the default note call, and resetting
      in track eval?
    * Add serial field to Derive.Threaded.
    * Reset the seed in track eval, for each new UI event.
      . I put it in EvalTrack.derive_event_stream, but why not in
        derive_event_ctx?
      . One thing is that this only resets the serial for the whole
        expression, but I don't actually need that since the stack will have
        different Calls.  I'd want to reset per call.  But does per-expression
        hurt?  For per-call, I'd have to put it in Eval.eval_toplevel, and
        then it would need a way to tell if it was called from a track.
        . Well, since LPerf.control_vals has to pass 0 for the serial, using
          0 more often would make it more likely to be accurate.
      . What tests can I do to verify?
    * Include the serial in the seed calculation.
      . I need the seed when I look up cf-rnd-a, so it's in the note deriver?
        Yeah, Note.get_start_offset
      . So this means if I bump the serial at the end of
        Note.make_event_control_vals then it will be reflected in subsequent
        notes.
    * Tests to verify serial is reset for each event.
      . Or rather, that I get different randomization for each note in
        a single event, but randomization is not affected if a previous event
        changes.
-}