-- 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_environ, initial_controls, initial_control_vals, 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
    , ScaleCall(..)
    , ScaleF
    , scale_call
    , 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 as Vector

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 = forall st err. Msg -> Deriver st err ()
DeriveM.write forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Msg -> Deriver Msg
initialize_log_msg

initialize_log_msg :: Log.Msg -> Deriver Log.Msg
initialize_log_msg :: Msg -> Deriver 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Msg
msg
    Maybe Stack
Nothing -> do
        Stack
stack <- forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Stack
state_stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Msg
msg { msg_stack :: Maybe Stack
Log.msg_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
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)
            forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Stack
stack forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ErrorVal
val

data ErrorVal = GenericError !Text | CallError !CallError
    deriving (Int -> ErrorVal -> ShowS
[ErrorVal] -> ShowS
ErrorVal -> String
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) = 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
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
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
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
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
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: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TypeErrorT
err
        ArgError Text
err -> Text
err
        CallNotFound Symbol
sym -> Text
"CallNotFound: " forall a. Semigroup a => a -> a -> a
<> 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) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
        [ Text
"arg ", forall a. Pretty a => a -> Text
pretty ErrorPlace
place, Text
"/", Text
arg_name
        , Text
source_desc, Text
": expected ", forall a. Pretty a => a -> Text
pretty Type
expected
        ] forall a. [a] -> [a] -> [a]
++ case Maybe Val
mb_received of
            Just Val
received -> case Maybe Error
derive_error of
                Maybe Error
Nothing ->
                    [ Text
" but got ", forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.specific_type_of Val
received)
                    , Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Val
received
                    ]
                -- The srcpos and stack of the derive error is probably not
                -- interesting, so I strip those out.
                Just (Error CallStack
_ Stack
_ ErrorVal
msg) ->
                    [ Text
" but couldn't convert "
                    , forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.specific_type_of Val
received)
                    ,  Text
" ", forall a. Pretty a => a -> Text
pretty Val
received, Text
": ", forall a. Pretty a => a -> Text
pretty ErrorVal
msg
                    ]
            Maybe Val
Nothing -> case EvalSource
source of
                -- Otherwise the error is confusing, subtracks don't have
                -- error_received since they don't fit in a DeriveT.Val.
                -- But I only saw this due to Typecheck Maybe not propagating
                -- from_subtrack.
                SubTrack Either Text TrackId
_ ->
                    [Text
" but subtrack didn't make it through from_subtrack"]
                EvalSource
_ -> [Text
" but got no value"]
        where
        source_desc :: Text
source_desc = case EvalSource
source of
            EvalSource
Literal -> Text
""
            Quoted Quoted
call -> Text
" from " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Quoted
call
            SubTrack Either Text TrackId
source -> Text
" from subtrack:" forall a. Semigroup a => a -> a -> a
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. Show a => a -> Text
showt Either Text TrackId
source

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

throw :: GHC.Stack.HasCallStack => Text -> Deriver a
throw :: forall a. HasCallStack => Text -> Deriver a
throw = forall a. HasCallStack => ErrorVal -> Deriver a
throw_error 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 = forall a. HasCallStack => ErrorVal -> Deriver a
throw_error forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallError -> ErrorVal
CallError 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 <- forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Stack
state_stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
    forall err st a. err -> Deriver st err a
DeriveM.throw (CallStack -> Stack -> ErrorVal -> Error
Error 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 = 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => Text -> Deriver a
throw Text
msg) 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => Text -> Deriver a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
fmt_err) 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 = forall note control pitch. Scope note control pitch -> note
scope_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
    get_scopes_scope :: Scopes -> ScopePriority (Generator Event)
get_scopes_scope = forall note control pitch. Scope note control pitch -> note
scope_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall note control pitch. Scope note control pitch -> control
scope_control forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
    get_scopes_scope :: Scopes -> ScopePriority (Generator Control)
get_scopes_scope = forall note control pitch. Scope note control pitch -> control
scope_control forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall note control pitch. Scope note control pitch -> pitch
scope_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
    get_scopes_scope :: Scopes -> ScopePriority (Generator PSignal)
get_scopes_scope = forall note control pitch. Scope note control pitch -> pitch
scope_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall note control pitch. Scope note control pitch -> note
scope_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
    get_scopes_scope :: Scopes -> ScopePriority (Transformer Event)
get_scopes_scope = forall note control pitch. Scope note control pitch -> note
scope_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall note control pitch. Scope note control pitch -> control
scope_control forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
    get_scopes_scope :: Scopes -> ScopePriority (Transformer Control)
get_scopes_scope = forall note control pitch. Scope note control pitch -> control
scope_control forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall note control pitch. Scope note control pitch -> pitch
scope_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
    get_scopes_scope :: Scopes -> ScopePriority (Transformer PSignal)
get_scopes_scope = forall note control pitch. Scope note control pitch -> pitch
scope_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall note control pitch. Scope note control pitch -> note
scope_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
    get_scopes_scope :: Scopes -> ScopePriority (TrackCall Event)
get_scopes_scope = forall note control pitch. Scope note control pitch -> note
scope_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall note control pitch. Scope note control pitch -> control
scope_control forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
    get_scopes_scope :: Scopes -> ScopePriority (TrackCall Control)
get_scopes_scope = forall note control pitch. Scope note control pitch -> control
scope_control forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall note control pitch. Scope note control pitch -> pitch
scope_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
    get_scopes_scope :: Scopes -> ScopePriority (TrackCall PSignal)
get_scopes_scope = forall note control pitch. Scope note control pitch -> pitch
scope_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall gen trans track val. ScopesT gen trans track val -> val
scopes_val
    get_scopes_scope :: Scopes -> ScopePriority ValCall
get_scopes_scope = 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
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) = forall a. Pretty a => a -> Doc
Pretty.format Event
a
    format (TagControl Control
a) = forall a. Pretty a => a -> Doc
Pretty.format Control
a
    format (TagPitch PSignal
a) = 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 = forall a. a -> a
id
    from_tagged :: Tagged -> Maybe Tagged
from_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) = forall a. a -> Maybe a
Just Event
a
    from_tagged Tagged
_ = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
    mappend :: NoteDeriver -> NoteDeriver -> NoteDeriver
mappend = 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) = forall a. a -> Maybe a
Just Control
a
    from_tagged Tagged
_ = 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) = forall a. a -> Maybe a
Just PSignal
a
    from_tagged Tagged
_ = 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 = 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
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 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 {
    Dynamic -> Map Control Merger
state_control_merge_defaults :: !(Map ScoreT.Control Merger)
    -- | 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_environ'
    -- 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_control_merge_defaults :: Map Control Merger
state_control_merge_defaults = Map Control Merger
initial_control_merge_defaults
    , state_pitch :: PSignal
state_pitch = forall a. Monoid a => a
mempty
    , state_environ :: Environ
state_environ = Environ
environ forall a. Semigroup a => a -> a -> a
<> Environ
initial_environ
    , state_warp :: Warp
state_warp = Warp
Warp.identity
    , state_scopes :: Scopes
state_scopes = forall a. Monoid a => a
mempty
    , state_instrument_aliases :: InstrumentAliases
state_instrument_aliases = forall a. Monoid a => a
mempty
    , state_control_damage :: ControlDamage
state_control_damage = forall a. Monoid a => a
mempty
    , state_under_invert :: NoteDeriver -> NoteDeriver
state_under_invert = forall a. a -> a
id
    , state_inversion :: Inversion
state_inversion = Inversion
NotInverted
    , state_pitch_map :: Maybe (Maybe PSignal, [Msg])
state_pitch_map = forall a. Maybe a
Nothing
    , state_note_track :: Maybe (BlockId, TrackId)
state_note_track = 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 = forall a. Maybe a
Nothing }
{-# INLINE strip_dynamic #-}

-- TODO This could go into PlayUtil.initial_environ, but there are
-- already a bunch of tests that call initial_dynamic directly and
-- probably rely on these controls being in there.
initial_environ :: DeriveT.Environ
initial_environ :: Environ
initial_environ = Map Text Val -> Environ
DeriveT.Environ forall a b. (a -> b) -> a -> b
$ forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
    [ (Control -> Text
ScoreT.control_name Control
c, Typed Control -> Val
DeriveT.VSignal Typed Control
s)
    | (Control
c, Typed Control
s) <- forall k a. Map k a -> [(k, a)]
Map.toAscList ControlMap
initial_controls
    ]

-- | Initial control environment.
initial_controls :: ScoreT.ControlMap
initial_controls :: ControlMap
initial_controls = forall a. a -> Typed a
ScoreT.untyped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Y -> Signal kind
Signal.constant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Control Y
initial_control_vals

initial_control_vals :: Map ScoreT.Control Signal.Y
initial_control_vals :: Map Control Y
initial_control_vals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Control
Controls.dynamic, Y
default_dynamic)
    ]

initial_control_merge_defaults :: Map ScoreT.Control Merger
initial_control_merge_defaults :: Map Control Merger
initial_control_merge_defaults =
    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 Map Control Merger
cmerge 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
"control_merge_defaults", forall a. Pretty a => a -> Doc
Pretty.format Map Control Merger
cmerge)
            , (Text
"pitch", forall a. Pretty a => a -> Doc
Pretty.format PSignal
pitch)
            , (Text
"environ", forall a. Pretty a => a -> Doc
Pretty.format Environ
environ)
            , (Text
"warp", forall a. Pretty a => a -> Doc
Pretty.format Warp
warp)
            , (Text
"scopes", forall a. Pretty a => a -> Doc
Pretty.format Scopes
scopes)
            , (Text
"instrument_aliases", forall a. Pretty a => a -> Doc
Pretty.format InstrumentAliases
aliases)
            , (Text
"control_damage", forall a. Pretty a => a -> Doc
Pretty.format ControlDamage
control_damage)
            , (Text
"inversion", forall a. Pretty a => a -> Doc
Pretty.format Inversion
inversion)
            , (Text
"pitch_map", forall a. Pretty a => a -> Doc
Pretty.format Maybe (Maybe PSignal, [Msg])
pitch_map)
            , (Text
"note_track", forall a. Pretty a => a -> Doc
Pretty.format Maybe (BlockId, TrackId)
note_track)
            , (Text
"stack", forall a. Pretty a => a -> Doc
Pretty.format Stack
stack)
            , (Text
"mode", forall a. Pretty a => a -> Doc
Pretty.format Mode
mode)
            ]

instance DeepSeq.NFData Dynamic where
    rnf :: Dynamic -> ()
rnf (Dynamic Map Control Merger
cmerge 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) =
        forall a. NFData a => a -> ()
rnf Map Control Merger
cmerge seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf PSignal
pitch seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Environ
environ seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Warp
warp
        seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf InstrumentAliases
aliases seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf ControlDamage
control_damage seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Maybe (Maybe PSignal, [Msg])
pitch_map
        seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Maybe (BlockId, TrackId)
note_track seq :: forall a b. a -> b -> b
`seq` 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 = forall call. Map Symbol call -> [PatternCall call] -> CallMap call
CallMap (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 = forall call. Map Symbol call -> [PatternCall call] -> CallMap call
CallMap (Map Symbol call
a1forall a. Semigroup a => a -> a -> a
<>Map Symbol call
b1) ([PatternCall call]
a2forall a. Semigroup a => a -> a -> a
<>[PatternCall call]
b2)
instance Monoid (CallMap call) where
    mempty :: CallMap call
mempty = forall call. Map Symbol call -> [PatternCall call] -> CallMap call
CallMap forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    mappend :: CallMap call -> CallMap call -> CallMap call
mappend = 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", forall a. Pretty a => a -> Doc
Pretty.format (forall k a. Map k a -> [k]
Map.keys Map Symbol call
cmap))
        , (Text
"patterns", 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 = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens 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 (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 = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens 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 (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 = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens 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 (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 = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens 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 (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", forall a. Pretty a => a -> Doc
Pretty.format gen
gen)
        , (Text
"transformer", forall a. Pretty a => a -> Doc
Pretty.format trans
trans)
        , (Text
"track", forall a. Pretty a => a -> Doc
Pretty.format track
track)
        , (Text
"val", 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 =
        forall gen trans track val.
gen -> trans -> track -> val -> ScopesT gen trans track val
Scopes (gen
a1forall a. Semigroup a => a -> a -> a
<>gen
b1) (trans
a2forall a. Semigroup a => a -> a -> a
<>trans
b2) (track
a3forall a. Semigroup a => a -> a -> a
<>track
b3) (val
a4forall a. Semigroup a => a -> a -> a
<>val
b4)
instance (Monoid gen, Monoid trans, Monoid track, Monoid val) =>
        Monoid (ScopesT gen trans track val) where
    mempty :: ScopesT gen trans track val
mempty = forall gen trans track val.
gen -> trans -> track -> val -> ScopesT gen trans track val
Scopes forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    mappend :: ScopesT gen trans track val
-> ScopesT gen trans track val -> ScopesT gen trans track val
mappend = 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 = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens 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 (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 = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens 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 (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 = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens 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 (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", forall a. Pretty a => a -> Doc
Pretty.format note
note)
        , (Text
"control", forall a. Pretty a => a -> Doc
Pretty.format control
control)
        , (Text
"pitch", 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 =
        forall note control pitch.
note -> control -> pitch -> Scope note control pitch
Scope (note
a1forall a. Semigroup a => a -> a -> a
<>note
b1) (control
a2forall a. Semigroup a => a -> a -> a
<>control
b2) (pitch
a3forall a. Semigroup a => a -> a -> a
<>pitch
b3)
instance (Monoid note, Monoid control, Monoid pitch) =>
        Monoid (Scope note control pitch) where
    mempty :: Scope note control pitch
mempty = forall note control pitch.
note -> control -> pitch -> Scope note control pitch
Scope forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    mappend :: Scope note control pitch
-> Scope note control pitch -> Scope note control pitch
mappend = 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
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 = forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority (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 = forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority forall a. Monoid a => a
mempty
    mappend :: ScopePriority call -> ScopePriority call -> ScopePriority call
mappend = 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
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
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
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 = 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 = forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
    forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault 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) =
    forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith 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) =
    forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority forall a b. (a -> b) -> a -> b
$ 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 (forall func. Call func -> CallName
call_name Call d
call) (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 (forall d. TrackCall d -> CallName
tcall_name TrackCall d
tcall) (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 " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall d. TrackCall d -> CallName
tcall_name TrackCall d
tcall) forall a. Semigroup a => a -> a -> a
<> String
"))"
instance Pretty (TrackCall d) where
    pretty :: TrackCall d -> Text
pretty = forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = forall call.
(Scopes -> ScopePriority call)
-> (Builtins -> ModuleMap call) -> Symbol -> Deriver (Maybe call)
lookup_call_with forall call. Callable call => Scopes -> ScopePriority call
get_scopes_scope 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 <- forall call.
(Scopes -> ScopePriority call) -> Deriver [CallMap call]
get_call_maps Scopes -> ScopePriority call
get_scopes
    forall call. [CallMap call] -> Symbol -> Deriver (Maybe call)
lookup_call_maps [CallMap call]
cmaps Symbol
sym forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just call
call -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just (Module
mod, Symbol
sym) -> 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 = forall a. Maybe a
Nothing
    | Bool
otherwise = 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) = HasCallStack => 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 <- forall st a err. (st -> a) -> Deriver st err a
gets forall a b. (a -> b) -> a -> b
$ Builtins -> ModuleMap call
get_scope forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constant -> Builtins
state_builtins forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        CallMap call
cmap <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
module_ ModuleMap call
by_module
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
sym (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 <- forall st a err. (st -> a) -> Deriver st err a
gets forall a b. (a -> b) -> a -> b
$ Scopes -> ScopePriority call
get forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Scopes
state_scopes forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
sym Map Symbol call
cmap of
    Just call
call -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just call
call
    Maybe call
Nothing -> forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a b. (a -> b) -> a -> b
$Symbol
sym) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
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.<+> forall a. Pretty a => a -> Doc
Pretty.format Config
config
    format Mode
mode = Text -> Doc
Pretty.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
    , Constant -> Map CallName ScaleCall
state_scale_calls :: !(Map CallName ScaleCall)
    -- | 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
    -> Map CallName ScaleCall -> (ScoreT.Instrument -> Either Text Instrument)
    -> Cache -> ScoreDamage -> Constant
initial_constant :: State
-> Builtins
-> LookupScale
-> Map CallName ScaleCall
-> (Instrument -> Either Text Instrument)
-> Cache
-> ScoreDamage
-> Constant
initial_constant State
ui_state Builtins
builtins LookupScale
lookup_scale Map CallName ScaleCall
scale_calls 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_scale_calls :: Map CallName ScaleCall
state_scale_calls = Map CallName ScaleCall
scale_calls
        , 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 -> Map Control Y
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
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 "
        forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [forall a. Pretty a => a -> String
prettys CallMap (Generator Event)
gen, forall a. Pretty a => a -> String
prettys CallMap (Transformer Event)
trans, forall a. Pretty a => a -> String
prettys CallMap (TrackCall Event)
tracks, forall a. Pretty a => a -> String
prettys CallMap ValCall
val]
        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
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 = 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 = forall a. ShowVal a => a -> Text
ShowVal.show_val
instance Show Merger where
    show :: Merger -> String
show Merger
merger = String
"((Merger " forall a. [a] -> [a] -> [a]
++ Text -> String
untxt (forall a. ShowVal a => a -> Text
ShowVal.show_val Merger
merger) 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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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 (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
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
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", 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 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 forall a. Monoid a => a
mempty
    mappend :: CacheStats -> CacheStats -> CacheStats
mappend = 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", forall a. Pretty a => a -> Doc
Pretty.format WarpMap
warp_map)
            , (Text
"track_signals", forall a. Pretty a => a -> Doc
Pretty.format TrackSignals
tsigs)
            , (Text
"signal_fragments", forall a. Pretty a => a -> Doc
Pretty.format SignalFragments
frags)
            , (Text
"track_dynamic", forall a. Pretty a => a -> Doc
Pretty.format TrackDynamic
trackdyn)
            , (Text
"track_dynamic_inverted", forall a. Pretty a => a -> Doc
Pretty.format TrackDynamic
trackdyn_inv)
            , (Text
"block_deps", forall a. Pretty a => a -> Doc
Pretty.format BlockDeps
deps)
            , (Text
"cache", forall a. Pretty a => a -> Doc
Pretty.format Cache
cache)
            , (Text
"cache_stats", forall a. Pretty a => a -> Doc
Pretty.format CacheStats
cache_stats)
            , (Text
"integrated", forall a. Pretty a => a -> Doc
Pretty.format [Integrated]
integrated)
            , (Text
"control_mods", forall a. Pretty a => a -> Doc
Pretty.format [ControlMod]
cmods)
            , (Text
"call duration", forall a. Pretty a => a -> Doc
Pretty.format CallDuration ScoreTime
call_dur)
            , (Text
"call end", 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 forall a. Semigroup a => a -> a -> a
<> WarpMap
warps2)
            (TrackSignals
tsigs1 forall a. Semigroup a => a -> a -> a
<> TrackSignals
tsigs2) (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>) SignalFragments
frags1 SignalFragments
frags2)
            (TrackDynamic
trackdyn1 forall a. Semigroup a => a -> a -> a
<> TrackDynamic
trackdyn2) (TrackDynamic
trackdyn_inv1 forall a. Semigroup a => a -> a -> a
<> TrackDynamic
trackdyn_inv2)
            (BlockDeps
deps1 forall a. Semigroup a => a -> a -> a
<> BlockDeps
deps2) (Cache
cache1 forall a. Semigroup a => a -> a -> a
<> Cache
cache2) (CacheStats
cstats1 forall a. Semigroup a => a -> a -> a
<> CacheStats
cstats2)
            ([Integrated]
integrated1 forall a. Semigroup a => a -> a -> a
<> [Integrated]
integrated2) ([ControlMod]
cmods1 forall a. Semigroup a => a -> a -> a
<> [ControlMod]
cmods2) (CallDuration ScoreTime
cdur1 forall a. Semigroup a => a -> a -> a
<> CallDuration ScoreTime
cdur2)
            (CallDuration RealTime
cend1 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 forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
        forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    mappend :: Collect -> Collect -> Collect
mappend = 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) =
        forall a. NFData a => a -> ()
rnf WarpMap
warp_map seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf TrackSignals
frags seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf SignalFragments
tsigs seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf TrackDynamic
track_dyn
        seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf TrackDynamic
track_dyn_inv seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf BlockDeps
local_dep seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Cache
cache
        seq :: forall a b. a -> b -> b
`seq` 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
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"
            [forall a. Pretty a => a -> Doc
Pretty.format Control
control, forall a. Pretty a => a -> Doc
Pretty.format Control
signal, 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
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", forall a. Pretty a => a -> Doc
Pretty.format Either BlockId TrackId
source)
        , (Text
"events", 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) = forall a. NFData a => a -> ()
rnf Either BlockId TrackId
source seq :: forall a b. a -> b -> b
`seq` 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
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
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 = 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 = forall a. CallDuration a
Unknown
    mappend :: CallDuration a -> CallDuration a -> CallDuration a
mappend = 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 = 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:" forall a. Semigroup a => a -> a -> a
<> 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 -> 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", forall a. Pretty a => a -> Doc
Pretty.format [Val]
vals)
        , (Text
"call_name", forall a. Pretty a => a -> Doc
Pretty.format CallName
call_name)
        , (Text
"info", 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 -> 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 forall a. Num a => a -> a -> a
+ forall val. Context val -> ScoreTime
ctx_event_end Context a
info)
    where shifted :: ScoreTime
shifted = 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", forall a. Pretty a => a -> Doc
Pretty.format Maybe val
prev_val)
            , (Text
"event", forall a. Pretty a => a -> Doc
Pretty.format Event
event)
            , (Text
"prev_events", forall a. Pretty a => a -> Doc
Pretty.format [Event]
prev_events)
            , (Text
"next_events", forall a. Pretty a => a -> Doc
Pretty.format [Event]
next_events)
            , (Text
"event_end", forall a. Pretty a => a -> Doc
Pretty.format ScoreTime
event_end)
            , (Text
"track_range", forall a. Pretty a => a -> Doc
Pretty.format ScoreTime
track_range)
            , (Text
"sub_tracks", forall a. Pretty a => a -> Doc
Pretty.format EventsTree
sub_tracks)
            , (Text
"sub_events", forall a. Pretty a => a -> Doc
Pretty.format forall a b. (a -> b) -> a -> b
$
                forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (\(ScoreTime
s, ScoreTime
d, NoteDeriver
_) -> (ScoreTime
s, ScoreTime
d))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
sub_events)
            , (Text
"track_type", 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 = 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 = 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 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 = forall a. Maybe a
Nothing
    , ctx_track_type :: Maybe Type
ctx_track_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 = forall a. Taggable a => a -> Tagged
to_tagged forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. Taggable a => Tagged -> Maybe a
from_tagged forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall func. Call func -> CallName
call_name Call d
call) forall a. Semigroup a => a -> a -> a
<> String
"))"
instance Pretty (Call d) where
    pretty :: Call d -> Text
pretty = forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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)

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

-- | 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 = forall d. PassedArgs d -> Deriver (CallDuration ScoreTime)
default_score_duration
    , gfunc_real_duration :: PassedArgs d -> Deriver (CallDuration RealTime)
gfunc_real_duration = 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 =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> CallDuration a
CallDuration forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> ScoreTime
Event.duration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall val. Context val -> Event
ctx_event forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. a -> CallDuration a
CallDuration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ScoreTime -> Deriver RealTime
score_to_real (Event -> ScoreTime
Event.duration forall a b. (a -> b) -> a -> b
$ forall val. Context val -> Event
ctx_event forall a b. (a -> b) -> a -> b
$ forall val. PassedArgs val -> Context val
passed_ctx PassedArgs 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) =
    forall func.
Module -> CallName -> Tags -> Doc -> WithArgDoc func -> Call func
make_call Module
module_ CallName
name Tags
tags Doc
doc (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) =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
generator Module
module_ CallName
name Tags
tags Doc
doc
        ((forall a. [a] -> Stream a
Stream.from_sorted_events <$>) 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) =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
generator Module
module_ CallName
name Tags
tags Doc
doc
        ((forall a. a -> Stream a
Stream.from_event <$>) 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 = (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 = (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 = 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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CallName
name 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
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
[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
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 -> ()
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) = 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
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
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
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 -> ()
forall a. (a -> ()) -> NFData a
rnf :: CacheKey -> ()
$crnf :: CacheKey -> ()
DeepSeq.NFData, [CacheKey] -> Doc
CacheKey -> Text
CacheKey -> Doc
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) = forall a. Pretty a => a -> Doc
Pretty.format CacheEntry
entry

instance DeepSeq.NFData Cached where
    rnf :: Cached -> ()
rnf Cached
Invalid = ()
    rnf (Cached CacheEntry
entry) = 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)) = forall a. Pretty a => a -> Doc
Pretty.format Stream Event
events
    format (CachedControl (CallType Collect
_ Stream Control
events)) = forall a. Pretty a => a -> Doc
Pretty.format Stream Control
events
    format (CachedPitch (CallType Collect
_ Stream PSignal
events)) = forall a. Pretty a => a -> Doc
Pretty.format Stream PSignal
events

instance DeepSeq.NFData CacheEntry where
    rnf :: CacheEntry -> ()
rnf (CachedEvents CallType Event
c) = forall a. NFData a => a -> ()
rnf CallType Event
c
    rnf (CachedControl CallType Control
c) = forall a. NFData a => a -> ()
rnf CallType Control
c
    rnf (CachedPitch CallType PSignal
c) = 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) = forall a. NFData a => a -> ()
rnf Collect
collect seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Stream d
events

-- ** deps

newtype BlockDeps = BlockDeps (Set BlockId)
    deriving ([BlockDeps] -> Doc
BlockDeps -> Text
BlockDeps -> Doc
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
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
[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
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
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 -> ()
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
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
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 (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 forall a. Semigroup a => a -> a -> a
<> Set BlockId
tblocks2) (Set BlockId
blocks1 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 forall k a. Map k a
Map.empty forall a. Set a
Set.empty forall a. Set a
Set.empty
    mappend :: ScoreDamage -> ScoreDamage -> ScoreDamage
mappend = 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", forall a. Pretty a => a -> Doc
Pretty.format Map TrackId (Ranges ScoreTime)
tracks)
            , (Text
"track_blocks", forall a. Pretty a => a -> Doc
Pretty.format Set BlockId
track_blocks)
            , (Text
"blocks", 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) =
        forall a. NFData a => a -> ()
rnf Map TrackId (Ranges ScoreTime)
tracks seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Set BlockId
track_blocks seq :: forall a b. a -> b -> b
`seq` 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 forall a b. (a -> b) -> a -> b
$ forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey CacheKey -> Cached -> Cached
invalidate forall a b. (a -> b) -> a -> b
$ 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 = 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) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (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) -> 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 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
track_id Map TrackId (Ranges ScoreTime)
tracks ->
                    forall n. Ord n => Ranges n -> Ranges n -> Bool
Ranges.overlapping Ranges ScoreTime
ranges (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
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
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
[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
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
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 -> ()
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 RealTime
score_to_real ScoreTime
pos = do
    Warp
warp <- forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Warp
state_warp forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Warp
state_warp forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
    forall (m :: * -> *) a. Monad m => a -> m a
return 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.

-- | Like ValCall, but specialized to return Scale, which is not a first class
-- Val.
data ScaleCall = ScaleCall {
    ScaleCall -> CallName
scall_name :: CallName
    , ScaleCall -> CallDoc
scall_doc :: !CallDoc
    -- ValCall takes PassedArgs, but scales don't need Context.
    , ScaleCall -> ScaleF
scall_call :: ScaleF
    }

type ScaleF = [DeriveT.Val] -> Deriver Scale

scale_call :: CallName -> Doc.Doc -> (ScaleF, [ArgDoc])
    -> ScaleCall
scale_call :: CallName -> Doc -> (ScaleF, [ArgDoc]) -> ScaleCall
scale_call CallName
name Doc
doc (ScaleF
call, [ArgDoc]
arg_docs) = ScaleCall
    { scall_name :: CallName
scall_name = CallName
name
    , scall_doc :: CallDoc
scall_doc = CallDoc
        { cdoc_module :: Module
cdoc_module = Module
Module.prelude
        , cdoc_tags :: Tags
cdoc_tags = forall a. Monoid a => a
mempty
        , cdoc_doc :: Doc
cdoc_doc = Doc
doc
        , cdoc_args :: [ArgDoc]
cdoc_args = [ArgDoc]
arg_docs
        }
    , scall_call :: ScaleF
scall_call = ScaleF
call
    }

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 = forall a. Pretty a => a -> Text
pretty 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
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.Vector Pitch.Semi

-- * merge

-- | Merge the events of the given derivers.
d_merge :: [NoteDeriver] -> NoteDeriver
d_merge :: [NoteDeriver] -> NoteDeriver
d_merge [] = forall a. Monoid a => a
mempty
d_merge [NoteDeriver
d] = NoteDeriver
d
d_merge [NoteDeriver]
derivers = forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs [Msg]
logs Stream a
stream
    Left Error
err -> forall a. [Msg] -> Stream a
Stream.from_logs forall a b. (a -> b) -> a -> b
$ Error -> Msg
error_to_warn Error
err 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 (forall a. a -> Maybe a
Just Stack
stack) (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.
-}