{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ConstraintKinds #-}
module Derive.Deriver.Monad (
Deriver, RunResult
, modify, get, gets, put, run
, initialize_log_msg
, Error(..), ErrorVal(..), CallError(..), TypeErrorT(..), ErrorPlace(..)
, EvalSource(..)
, throw, throw_arg_error, throw_error
, annotate
, require, require_right
, Callable, callable_name, Tagged(..), Taggable(..)
, CallableExpr
, Note, NoteDeriver, NoteArgs
, Control, ControlDeriver, ControlArgs
, Pitch, PitchDeriver, PitchArgs
, lookup_call
, State(..), initial_state
, Threaded(..), initial_threaded
, Dynamic(..), InstrumentAliases, Inversion(..), initial_dynamic
, strip_dynamic
, initial_controls, default_dynamic
, 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(..), track_call
, Constant(..), initial_constant
, Mode(..)
, mergers, merge_add, merge_sub, merge_mul, merge_scale
, Instrument(..), InstrumentCalls
, Merge(..), Merger(..)
, Collect(..), CacheStats(..), SignalFragments
, ControlMod(..), Integrated(..)
, TrackDynamic, CallDuration(..)
, 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, GeneratorFunc(..), GeneratorF, generator_func
, generator, generator_events, generator1
, with_score_duration, with_real_duration
, Transformer, TransformerF
, transformer
, ValCall(..), make_val_call
, Cache(..), CacheKey(..), Cached(..), cache_size
, CacheEntry(..), CallType(..)
, BlockDeps(..)
, ScoreDamage(..)
, ControlDamage(..)
, score_to_real, real_to_score
, Scale(..)
, LookupScale(..)
, Transpose, Transposition(..), Enharmonics, Layout
, error_to_warn, merge_logs
, invalidate_damaged
) where
import qualified Control.DeepSeq as DeepSeq
import Control.DeepSeq (rnf)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.String as String
import qualified Data.Text as Text
import qualified Data.Vector.Unboxed as Vector.Unboxed
import qualified GHC.Stack
import qualified Util.CallStack as CallStack
import qualified Util.Doc as Doc
import qualified Util.Lens as Lens
import qualified Util.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Pretty as Pretty
import qualified Util.Ranges as Ranges
import qualified Derive.Attrs as Attrs
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.DeriveM as DeriveM
import Derive.Deriver.DeriveM (get, gets, modify, put, run)
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.PSignal as PSignal
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream
import qualified Derive.TrackWarp as TrackWarp
import qualified Derive.ValType as ValType
import qualified Derive.Warp as Warp
import qualified Perform.Lilypond.Types as Lilypond.Types
import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal
import qualified Synth.Shared.Note as Shared.Note
import qualified Ui.Event as Event
import qualified Ui.Symbol as Symbol
import qualified Ui.Track as Track
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Ui as Ui
import Global
import Types
type Deriver = DeriveM.Deriver State Error
type RunResult a = DeriveM.RunResult State Error a
instance Log.LogMonad Deriver where
write :: Msg -> Deriver ()
write = Msg -> Deriver ()
forall st err. Msg -> Deriver st err ()
DeriveM.write (Msg -> Deriver ())
-> (Msg -> Deriver State Error Msg) -> Msg -> Deriver ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Msg -> Deriver State Error Msg
initialize_log_msg
initialize_log_msg :: Log.Msg -> Deriver Log.Msg
initialize_log_msg :: Msg -> Deriver State Error Msg
initialize_log_msg Msg
msg = case Msg -> Maybe Stack
Log.msg_stack Msg
msg of
Just Stack
_ -> Msg -> Deriver State Error Msg
forall (m :: * -> *) a. Monad m => a -> m a
return Msg
msg
Maybe Stack
Nothing -> do
Stack
stack <- (State -> Stack) -> Deriver State Error Stack
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Stack
state_stack (Dynamic -> Stack) -> (State -> Dynamic) -> State -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
Msg -> Deriver State Error Msg
forall (m :: * -> *) a. Monad m => a -> m a
return (Msg -> Deriver State Error Msg) -> Msg -> Deriver State Error Msg
forall a b. (a -> b) -> a -> b
$! Msg
msg { msg_stack :: Maybe Stack
Log.msg_stack = Stack -> Maybe Stack
forall a. a -> Maybe a
Just Stack
stack }
data Error = Error !GHC.Stack.CallStack !Stack.Stack !ErrorVal
deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)
instance Pretty Error where
pretty :: Error -> Text
pretty (Error CallStack
call_stack Stack
stack ErrorVal
val) =
Caller -> Text
CallStack.showCaller (CallStack -> Caller
CallStack.caller CallStack
call_stack)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Stack -> Text
forall a. Pretty a => a -> Text
pretty Stack
stack Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ErrorVal -> Text
forall a. Pretty a => a -> Text
pretty ErrorVal
val
data ErrorVal = GenericError !Text | CallError !CallError
deriving (Int -> ErrorVal -> ShowS
[ErrorVal] -> ShowS
ErrorVal -> String
(Int -> ErrorVal -> ShowS)
-> (ErrorVal -> String) -> ([ErrorVal] -> ShowS) -> Show ErrorVal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorVal] -> ShowS
$cshowList :: [ErrorVal] -> ShowS
show :: ErrorVal -> String
$cshow :: ErrorVal -> String
showsPrec :: Int -> ErrorVal -> ShowS
$cshowsPrec :: Int -> ErrorVal -> ShowS
Show)
instance Pretty ErrorVal where
pretty :: ErrorVal -> Text
pretty (GenericError Text
s) = Text
s
pretty (CallError CallError
err) = CallError -> Text
forall a. Pretty a => a -> Text
pretty CallError
err
data CallError =
TypeError !TypeErrorT
| CallNotFound !Expr.Symbol
| ArgError !Text
deriving (Int -> CallError -> ShowS
[CallError] -> ShowS
CallError -> String
(Int -> CallError -> ShowS)
-> (CallError -> String)
-> ([CallError] -> ShowS)
-> Show CallError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallError] -> ShowS
$cshowList :: [CallError] -> ShowS
show :: CallError -> String
$cshow :: CallError -> String
showsPrec :: Int -> CallError -> ShowS
$cshowsPrec :: Int -> CallError -> ShowS
Show)
data TypeErrorT = TypeErrorT {
TypeErrorT -> ErrorPlace
error_place :: !ErrorPlace
, TypeErrorT -> EvalSource
error_source :: !EvalSource
, TypeErrorT -> ArgName
error_arg_name :: !ArgName
, TypeErrorT -> Type
error_expected :: !ValType.Type
, TypeErrorT -> Maybe Val
error_received :: !(Maybe DeriveT.Val)
, TypeErrorT -> Maybe Error
error_derive :: !(Maybe Error)
} deriving (Int -> TypeErrorT -> ShowS
[TypeErrorT] -> ShowS
TypeErrorT -> String
(Int -> TypeErrorT -> ShowS)
-> (TypeErrorT -> String)
-> ([TypeErrorT] -> ShowS)
-> Show TypeErrorT
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeErrorT] -> ShowS
$cshowList :: [TypeErrorT] -> ShowS
show :: TypeErrorT -> String
$cshow :: TypeErrorT -> String
showsPrec :: Int -> TypeErrorT -> ShowS
$cshowsPrec :: Int -> TypeErrorT -> ShowS
Show)
data ErrorPlace = TypeErrorArg !Int | TypeErrorEnviron !EnvKey.Key
deriving (ErrorPlace -> ErrorPlace -> Bool
(ErrorPlace -> ErrorPlace -> Bool)
-> (ErrorPlace -> ErrorPlace -> Bool) -> Eq ErrorPlace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorPlace -> ErrorPlace -> Bool
$c/= :: ErrorPlace -> ErrorPlace -> Bool
== :: ErrorPlace -> ErrorPlace -> Bool
$c== :: ErrorPlace -> ErrorPlace -> Bool
Eq, Int -> ErrorPlace -> ShowS
[ErrorPlace] -> ShowS
ErrorPlace -> String
(Int -> ErrorPlace -> ShowS)
-> (ErrorPlace -> String)
-> ([ErrorPlace] -> ShowS)
-> Show ErrorPlace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorPlace] -> ShowS
$cshowList :: [ErrorPlace] -> ShowS
show :: ErrorPlace -> String
$cshow :: ErrorPlace -> String
showsPrec :: Int -> ErrorPlace -> ShowS
$cshowsPrec :: Int -> ErrorPlace -> ShowS
Show)
data EvalSource =
Literal
| Quoted !DeriveT.Quoted
| SubTrack !(Either Text TrackId)
deriving (Int -> EvalSource -> ShowS
[EvalSource] -> ShowS
EvalSource -> String
(Int -> EvalSource -> ShowS)
-> (EvalSource -> String)
-> ([EvalSource] -> ShowS)
-> Show EvalSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EvalSource] -> ShowS
$cshowList :: [EvalSource] -> ShowS
show :: EvalSource -> String
$cshow :: EvalSource -> String
showsPrec :: Int -> EvalSource -> ShowS
$cshowsPrec :: Int -> EvalSource -> ShowS
Show)
instance Pretty CallError where
pretty :: CallError -> Text
pretty = \case
TypeError TypeErrorT
err -> Text
"TypeError: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeErrorT -> Text
forall a. Pretty a => a -> Text
pretty TypeErrorT
err
ArgError Text
err -> Text
err
CallNotFound Symbol
sym -> Text
"CallNotFound: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Symbol -> Text
forall a. Pretty a => a -> Text
pretty Symbol
sym
instance Pretty TypeErrorT where
pretty :: TypeErrorT -> Text
pretty (TypeErrorT ErrorPlace
place EvalSource
source (ArgName Text
arg_name) Type
expected Maybe Val
mb_received
Maybe Error
derive_error) = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ Text
"arg ", ErrorPlace -> Text
forall a. Pretty a => a -> Text
pretty ErrorPlace
place, Text
"/", Text
arg_name
, Text
source_desc, Text
": expected ", Type -> Text
forall a. Pretty a => a -> Text
pretty Type
expected
, case Maybe Val
mb_received of
Just Val
received -> Text
" but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.type_of Val
received)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Val -> Text
forall a. Pretty a => a -> Text
pretty Val
received
Maybe Val
Nothing -> Text
" but got no value"
, Text -> (Error -> Text) -> Maybe Error -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Error -> Text
show_derive_error Maybe Error
derive_error
]
where
source_desc :: Text
source_desc = case EvalSource
source of
EvalSource
Literal -> Text
""
Quoted Quoted
call -> Text
" from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Quoted -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Quoted
call
SubTrack Either Text TrackId
source -> Text
" from subtrack:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> (TrackId -> Text) -> Either Text TrackId -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id TrackId -> Text
forall a. Show a => a -> Text
showt Either Text TrackId
source
show_derive_error :: Error -> Text
show_derive_error (Error CallStack
_ Stack
_ ErrorVal
error_val) =
Text
" (the type conversion required derivation, which crashed: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ErrorVal -> Text
forall a. Pretty a => a -> Text
pretty ErrorVal
error_val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
instance Pretty ErrorPlace where
pretty :: ErrorPlace -> Text
pretty (TypeErrorArg Int
num) = Int -> Text
forall a. Show a => a -> Text
showt (Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
pretty (TypeErrorEnviron Text
key) = Text
"environ:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
pretty Text
key
throw :: GHC.Stack.HasCallStack => Text -> Deriver a
throw :: forall a. HasCallStack => Text -> Deriver a
throw = ErrorVal -> Deriver a
forall a. HasCallStack => ErrorVal -> Deriver a
throw_error (ErrorVal -> Deriver a) -> (Text -> ErrorVal) -> Text -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ErrorVal
GenericError
throw_arg_error :: GHC.Stack.HasCallStack => Text -> Deriver a
throw_arg_error :: forall a. HasCallStack => Text -> Deriver a
throw_arg_error = ErrorVal -> Deriver a
forall a. HasCallStack => ErrorVal -> Deriver a
throw_error (ErrorVal -> Deriver a) -> (Text -> ErrorVal) -> Text -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallError -> ErrorVal
CallError (CallError -> ErrorVal) -> (Text -> CallError) -> Text -> ErrorVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CallError
ArgError
throw_error :: GHC.Stack.HasCallStack => ErrorVal -> Deriver a
throw_error :: forall a. HasCallStack => ErrorVal -> Deriver a
throw_error ErrorVal
err = do
Stack
stack <- (State -> Stack) -> Deriver State Error Stack
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Stack
state_stack (Dynamic -> Stack) -> (State -> Dynamic) -> State -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
Error -> Deriver a
forall err st a. err -> Deriver st err a
DeriveM.throw (CallStack -> Stack -> ErrorVal -> Error
Error CallStack
HasCallStack => CallStack
GHC.Stack.callStack Stack
stack ErrorVal
err)
annotate :: (Error -> Error) -> Deriver a -> Deriver a
annotate :: forall a. (Error -> Error) -> Deriver a -> Deriver a
annotate Error -> Error
f = (Error -> Error) -> Deriver State Error a -> Deriver State Error a
forall err st a.
(err -> err) -> Deriver st err a -> Deriver st err a
DeriveM.annotate Error -> Error
f
require :: GHC.Stack.HasCallStack => Text -> Maybe a -> Deriver a
require :: forall a. HasCallStack => Text -> Maybe a -> Deriver a
require Text
msg = Deriver a -> (a -> Deriver a) -> Maybe a -> Deriver a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Deriver a
forall a. HasCallStack => Text -> Deriver a
throw Text
msg) a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return
require_right :: GHC.Stack.HasCallStack => (err -> Text) -> Either err a
-> Deriver a
require_right :: forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
require_right err -> Text
fmt_err = (err -> Deriver a) -> (a -> Deriver a) -> Either err a -> Deriver a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Deriver a
forall a. HasCallStack => Text -> Deriver a
throw (Text -> Deriver a) -> (err -> Text) -> err -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
fmt_err) a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return
type CallableExpr d =
( Callable (Generator d), Callable (Transformer d), Callable (TrackCall d)
, Taggable d
)
class Callable call where
get_builtins_scope :: Builtins -> ModuleMap call
get_scopes_scope :: Scopes -> ScopePriority call
callable_name :: Proxy call -> Text
instance Callable (Generator Note) where
get_builtins_scope :: Builtins -> ModuleMap (Generator Event)
get_builtins_scope = Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal))
-> ModuleMap (Generator Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal))
-> ModuleMap (Generator Event))
-> (Builtins
-> Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal)))
-> Builtins
-> ModuleMap (Generator Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
get_scopes_scope :: Scopes -> ScopePriority (Generator Event)
get_scopes_scope = Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal))
-> ScopePriority (Generator Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal))
-> ScopePriority (Generator Event))
-> (Scopes
-> Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal)))
-> Scopes
-> ScopePriority (Generator Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
callable_name :: Proxy (Generator Event) -> Text
callable_name Proxy (Generator Event)
_ = Text
"note generator"
instance Callable (Generator Control) where
get_builtins_scope :: Builtins -> ModuleMap (Generator Control)
get_builtins_scope = Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal))
-> ModuleMap (Generator Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal))
-> ModuleMap (Generator Control))
-> (Builtins
-> Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal)))
-> Builtins
-> ModuleMap (Generator Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
get_scopes_scope :: Scopes -> ScopePriority (Generator Control)
get_scopes_scope = Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal))
-> ScopePriority (Generator Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal))
-> ScopePriority (Generator Control))
-> (Scopes
-> Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal)))
-> Scopes
-> ScopePriority (Generator Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
callable_name :: Proxy (Generator Control) -> Text
callable_name Proxy (Generator Control)
_ = Text
"control generator"
instance Callable (Generator Pitch) where
get_builtins_scope :: Builtins -> ModuleMap (Generator PSignal)
get_builtins_scope = Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal))
-> ModuleMap (Generator PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal))
-> ModuleMap (Generator PSignal))
-> (Builtins
-> Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal)))
-> Builtins
-> ModuleMap (Generator PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
(ModuleMap (Generator Event))
(ModuleMap (Generator Control))
(ModuleMap (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
get_scopes_scope :: Scopes -> ScopePriority (Generator PSignal)
get_scopes_scope = Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal))
-> ScopePriority (Generator PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal))
-> ScopePriority (Generator PSignal))
-> (Scopes
-> Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal)))
-> Scopes
-> ScopePriority (Generator PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
(ScopePriority (Generator Event))
(ScopePriority (Generator Control))
(ScopePriority (Generator PSignal))
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
callable_name :: Proxy (Generator PSignal) -> Text
callable_name Proxy (Generator PSignal)
_ = Text
"pitch generator"
instance Callable (Transformer Note) where
get_builtins_scope :: Builtins -> ModuleMap (Transformer Event)
get_builtins_scope = Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal))
-> ModuleMap (Transformer Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal))
-> ModuleMap (Transformer Event))
-> (Builtins
-> Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal)))
-> Builtins
-> ModuleMap (Transformer Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
get_scopes_scope :: Scopes -> ScopePriority (Transformer Event)
get_scopes_scope = Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal))
-> ScopePriority (Transformer Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal))
-> ScopePriority (Transformer Event))
-> (Scopes
-> Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal)))
-> Scopes
-> ScopePriority (Transformer Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
callable_name :: Proxy (Transformer Event) -> Text
callable_name Proxy (Transformer Event)
_ = Text
"note transformer"
instance Callable (Transformer Control) where
get_builtins_scope :: Builtins -> ModuleMap (Transformer Control)
get_builtins_scope = Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal))
-> ModuleMap (Transformer Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal))
-> ModuleMap (Transformer Control))
-> (Builtins
-> Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal)))
-> Builtins
-> ModuleMap (Transformer Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
get_scopes_scope :: Scopes -> ScopePriority (Transformer Control)
get_scopes_scope = Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal))
-> ScopePriority (Transformer Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal))
-> ScopePriority (Transformer Control))
-> (Scopes
-> Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal)))
-> Scopes
-> ScopePriority (Transformer Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
callable_name :: Proxy (Transformer Control) -> Text
callable_name Proxy (Transformer Control)
_ = Text
"control transformer"
instance Callable (Transformer Pitch) where
get_builtins_scope :: Builtins -> ModuleMap (Transformer PSignal)
get_builtins_scope = Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal))
-> ModuleMap (Transformer PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal))
-> ModuleMap (Transformer PSignal))
-> (Builtins
-> Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal)))
-> Builtins
-> ModuleMap (Transformer PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
(ModuleMap (Transformer Event))
(ModuleMap (Transformer Control))
(ModuleMap (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
get_scopes_scope :: Scopes -> ScopePriority (Transformer PSignal)
get_scopes_scope = Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal))
-> ScopePriority (Transformer PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal))
-> ScopePriority (Transformer PSignal))
-> (Scopes
-> Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal)))
-> Scopes
-> ScopePriority (Transformer PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
(ScopePriority (Transformer Event))
(ScopePriority (Transformer Control))
(ScopePriority (Transformer PSignal))
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
callable_name :: Proxy (Transformer PSignal) -> Text
callable_name Proxy (Transformer PSignal)
_ = Text
"pitch transformer"
instance Callable (TrackCall Note) where
get_builtins_scope :: Builtins -> ModuleMap (TrackCall Event)
get_builtins_scope = Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal))
-> ModuleMap (TrackCall Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal))
-> ModuleMap (TrackCall Event))
-> (Builtins
-> Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal)))
-> Builtins
-> ModuleMap (TrackCall Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
get_scopes_scope :: Scopes -> ScopePriority (TrackCall Event)
get_scopes_scope = Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal))
-> ScopePriority (TrackCall Event)
forall note control pitch. Scope note control pitch -> note
scope_note (Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal))
-> ScopePriority (TrackCall Event))
-> (Scopes
-> Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal)))
-> Scopes
-> ScopePriority (TrackCall Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
callable_name :: Proxy (TrackCall Event) -> Text
callable_name Proxy (TrackCall Event)
_ = Text
"note track call"
instance Callable (TrackCall Control) where
get_builtins_scope :: Builtins -> ModuleMap (TrackCall Control)
get_builtins_scope = Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal))
-> ModuleMap (TrackCall Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal))
-> ModuleMap (TrackCall Control))
-> (Builtins
-> Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal)))
-> Builtins
-> ModuleMap (TrackCall Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
get_scopes_scope :: Scopes -> ScopePriority (TrackCall Control)
get_scopes_scope = Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal))
-> ScopePriority (TrackCall Control)
forall note control pitch. Scope note control pitch -> control
scope_control (Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal))
-> ScopePriority (TrackCall Control))
-> (Scopes
-> Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal)))
-> Scopes
-> ScopePriority (TrackCall Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
callable_name :: Proxy (TrackCall Control) -> Text
callable_name Proxy (TrackCall Control)
_ = Text
"control track call"
instance Callable (TrackCall Pitch) where
get_builtins_scope :: Builtins -> ModuleMap (TrackCall PSignal)
get_builtins_scope = Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal))
-> ModuleMap (TrackCall PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal))
-> ModuleMap (TrackCall PSignal))
-> (Builtins
-> Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal)))
-> Builtins
-> ModuleMap (TrackCall PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtins
-> Scope
(ModuleMap (TrackCall Event))
(ModuleMap (TrackCall Control))
(ModuleMap (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
get_scopes_scope :: Scopes -> ScopePriority (TrackCall PSignal)
get_scopes_scope = Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal))
-> ScopePriority (TrackCall PSignal)
forall note control pitch. Scope note control pitch -> pitch
scope_pitch (Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal))
-> ScopePriority (TrackCall PSignal))
-> (Scopes
-> Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal)))
-> Scopes
-> ScopePriority (TrackCall PSignal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes
-> Scope
(ScopePriority (TrackCall Event))
(ScopePriority (TrackCall Control))
(ScopePriority (TrackCall PSignal))
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
callable_name :: Proxy (TrackCall PSignal) -> Text
callable_name Proxy (TrackCall PSignal)
_ = Text
"pitch track call"
instance Callable ValCall where
get_builtins_scope :: Builtins -> ModuleMap ValCall
get_builtins_scope = Builtins -> ModuleMap ValCall
forall gen trans track val. ScopesT gen trans track val -> val
scopes_val
get_scopes_scope :: Scopes -> ScopePriority ValCall
get_scopes_scope = Scopes -> ScopePriority ValCall
forall gen trans track val. ScopesT gen trans track val -> val
scopes_val
callable_name :: Proxy ValCall -> Text
callable_name Proxy ValCall
_ = Text
"val call"
data Tagged = TagEvent Score.Event | TagControl Signal.Control
| TagPitch PSignal.PSignal
deriving (Int -> Tagged -> ShowS
[Tagged] -> ShowS
Tagged -> String
(Int -> Tagged -> ShowS)
-> (Tagged -> String) -> ([Tagged] -> ShowS) -> Show Tagged
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tagged] -> ShowS
$cshowList :: [Tagged] -> ShowS
show :: Tagged -> String
$cshow :: Tagged -> String
showsPrec :: Int -> Tagged -> ShowS
$cshowsPrec :: Int -> Tagged -> ShowS
Show)
instance Pretty Tagged where
format :: Tagged -> Doc
format (TagEvent Event
a) = Event -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Event
a
format (TagControl Control
a) = Control -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Control
a
format (TagPitch PSignal
a) = PSignal -> Doc
forall a. Pretty a => a -> Doc
Pretty.format PSignal
a
class (Show a, Pretty a) => Taggable a where
to_tagged :: a -> Tagged
from_tagged :: Tagged -> Maybe a
instance Taggable Tagged where
to_tagged :: Tagged -> Tagged
to_tagged = Tagged -> Tagged
forall a. a -> a
id
from_tagged :: Tagged -> Maybe Tagged
from_tagged = Tagged -> Maybe Tagged
forall a. a -> Maybe a
Just
type Note = Score.Event
type NoteDeriver = Deriver (Stream.Stream Score.Event)
type NoteArgs = PassedArgs Score.Event
instance Taggable Note where
to_tagged :: Event -> Tagged
to_tagged = Event -> Tagged
TagEvent
from_tagged :: Tagged -> Maybe Event
from_tagged (TagEvent Event
a) = Event -> Maybe Event
forall a. a -> Maybe a
Just Event
a
from_tagged Tagged
_ = Maybe Event
forall a. Maybe a
Nothing
instance Semigroup NoteDeriver where
NoteDeriver
d1 <> :: NoteDeriver -> NoteDeriver -> NoteDeriver
<> NoteDeriver
d2 = [NoteDeriver] -> NoteDeriver
d_merge [NoteDeriver
d1, NoteDeriver
d2]
instance Monoid NoteDeriver where
mempty :: NoteDeriver
mempty = Stream Event -> NoteDeriver
forall (m :: * -> *) a. Monad m => a -> m a
return Stream Event
forall a. Monoid a => a
mempty
mappend :: NoteDeriver -> NoteDeriver -> NoteDeriver
mappend = NoteDeriver -> NoteDeriver -> NoteDeriver
forall a. Semigroup a => a -> a -> a
(<>)
mconcat :: [NoteDeriver] -> NoteDeriver
mconcat = [NoteDeriver] -> NoteDeriver
d_merge
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>"
type Control = Signal.Control
type ControlDeriver = Deriver (Stream.Stream Signal.Control)
type ControlArgs = PassedArgs Control
instance Taggable Control where
to_tagged :: Control -> Tagged
to_tagged = Control -> Tagged
TagControl
from_tagged :: Tagged -> Maybe Control
from_tagged (TagControl Control
a) = Control -> Maybe Control
forall a. a -> Maybe a
Just Control
a
from_tagged Tagged
_ = Maybe Control
forall a. Maybe a
Nothing
type Pitch = PSignal.PSignal
type PitchDeriver = Deriver (Stream.Stream PSignal.PSignal)
type PitchArgs = PassedArgs Pitch
instance Taggable Pitch where
to_tagged :: PSignal -> Tagged
to_tagged = PSignal -> Tagged
TagPitch
from_tagged :: Tagged -> Maybe PSignal
from_tagged (TagPitch PSignal
a) = PSignal -> Maybe PSignal
forall a. a -> Maybe a
Just PSignal
a
from_tagged Tagged
_ = Maybe PSignal
forall a. Maybe a
Nothing
data State = State {
State -> Threaded
state_threaded :: !Threaded
, State -> Dynamic
state_dynamic :: !Dynamic
, State -> Collect
state_collect :: !Collect
, State -> Constant
state_constant :: !Constant
}
initial_state :: Constant -> Dynamic -> State
initial_state :: Constant -> Dynamic -> State
initial_state Constant
constant Dynamic
dynamic = State
{ state_threaded :: Threaded
state_threaded = Threaded
initial_threaded
, state_dynamic :: Dynamic
state_dynamic = Dynamic
dynamic
, state_collect :: Collect
state_collect = Collect
forall a. Monoid a => a
mempty
, state_constant :: Constant
state_constant = Constant
constant
}
data Threaded = Threaded {
Threaded -> Map (BlockId, TrackId) Tagged
state_prev_val :: !(Map (BlockId, TrackId) Tagged)
, Threaded -> Int
state_event_serial :: !Stack.Serial
} deriving (Int -> Threaded -> ShowS
[Threaded] -> ShowS
Threaded -> String
(Int -> Threaded -> ShowS)
-> (Threaded -> String) -> ([Threaded] -> ShowS) -> Show Threaded
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Threaded] -> ShowS
$cshowList :: [Threaded] -> ShowS
show :: Threaded -> String
$cshow :: Threaded -> String
showsPrec :: Int -> Threaded -> ShowS
$cshowsPrec :: Int -> Threaded -> ShowS
Show)
initial_threaded :: Threaded
initial_threaded :: Threaded
initial_threaded = Map (BlockId, TrackId) Tagged -> Int -> Threaded
Threaded Map (BlockId, TrackId) Tagged
forall a. Monoid a => a
mempty Int
0
data Dynamic = Dynamic {
Dynamic -> ControlMap
state_controls :: !DeriveT.ControlMap
, Dynamic -> ControlFunctionMap
state_control_functions :: !DeriveT.ControlFunctionMap
, Dynamic -> Map Control Merger
state_control_merge_defaults :: !(Map ScoreT.Control Merger)
, Dynamic -> PitchMap
state_pitches :: !DeriveT.PitchMap
, Dynamic -> PSignal
state_pitch :: !PSignal.PSignal
, Dynamic -> Environ
state_environ :: !DeriveT.Environ
, Dynamic -> Warp
state_warp :: !Warp.Warp
, Dynamic -> Scopes
state_scopes :: !Scopes
, Dynamic -> InstrumentAliases
state_instrument_aliases :: !InstrumentAliases
, Dynamic -> ControlDamage
state_control_damage :: !ControlDamage
, Dynamic -> NoteDeriver -> NoteDeriver
state_under_invert :: !(NoteDeriver -> NoteDeriver)
, Dynamic -> Inversion
state_inversion :: !Inversion
, Dynamic -> Maybe (Maybe PSignal, [Msg])
state_pitch_map :: !(Maybe (Maybe PSignal.PSignal, [Log.Msg]))
, Dynamic -> Maybe (BlockId, TrackId)
state_note_track :: !(Maybe (BlockId, TrackId))
, Dynamic -> Stack
state_stack :: !Stack.Stack
, Dynamic -> Mode
state_mode :: !Mode
}
type InstrumentAliases = Map ScoreT.Instrument ScoreT.Instrument
data Inversion =
NotInverted
| InversionInProgress !NoteDeriver
instance Pretty Inversion where
pretty :: Inversion -> Text
pretty Inversion
NotInverted = Text
"NotInverted"
pretty (InversionInProgress {}) = Text
"InversionInProgress"
initial_dynamic :: DeriveT.Environ -> Dynamic
initial_dynamic :: Environ -> Dynamic
initial_dynamic Environ
environ = Dynamic
{ state_controls :: ControlMap
state_controls = ControlMap
initial_controls
, state_control_functions :: ControlFunctionMap
state_control_functions = ControlFunctionMap
forall a. Monoid a => a
mempty
, state_control_merge_defaults :: Map Control Merger
state_control_merge_defaults = Map Control Merger
initial_control_merge_defaults
, state_pitches :: PitchMap
state_pitches = PitchMap
forall k a. Map k a
Map.empty
, state_pitch :: PSignal
state_pitch = PSignal
forall a. Monoid a => a
mempty
, state_environ :: Environ
state_environ = Environ
environ
, state_warp :: Warp
state_warp = Warp
Warp.identity
, state_scopes :: Scopes
state_scopes = Scopes
forall a. Monoid a => a
mempty
, state_instrument_aliases :: InstrumentAliases
state_instrument_aliases = InstrumentAliases
forall a. Monoid a => a
mempty
, state_control_damage :: ControlDamage
state_control_damage = ControlDamage
forall a. Monoid a => a
mempty
, state_under_invert :: NoteDeriver -> NoteDeriver
state_under_invert = NoteDeriver -> NoteDeriver
forall a. a -> a
id
, state_inversion :: Inversion
state_inversion = Inversion
NotInverted
, state_pitch_map :: Maybe (Maybe PSignal, [Msg])
state_pitch_map = Maybe (Maybe PSignal, [Msg])
forall a. Maybe a
Nothing
, state_note_track :: Maybe (BlockId, TrackId)
state_note_track = Maybe (BlockId, TrackId)
forall a. Maybe a
Nothing
, state_stack :: Stack
state_stack = Stack
Stack.empty
, state_mode :: Mode
state_mode = Mode
Normal
}
strip_dynamic :: Dynamic -> Dynamic
strip_dynamic :: Dynamic -> Dynamic
strip_dynamic Dynamic
dyn = Dynamic
dyn { state_pitch_map :: Maybe (Maybe PSignal, [Msg])
state_pitch_map = Maybe (Maybe PSignal, [Msg])
forall a. Maybe a
Nothing }
{-# INLINE strip_dynamic #-}
initial_controls :: DeriveT.ControlMap
initial_controls :: ControlMap
initial_controls = [(Control, Typed Control)] -> ControlMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (Control
Controls.dynamic, Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
default_dynamic))
]
initial_control_merge_defaults :: Map ScoreT.Control Merger
initial_control_merge_defaults :: Map Control Merger
initial_control_merge_defaults =
[(Control, Merger)] -> Map Control Merger
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Control
c, Merger
merge_add) | Control
c <- [Control]
Controls.additive_controls]
default_dynamic :: Signal.Y
default_dynamic :: Y
default_dynamic = Y
1
instance Pretty Dynamic where
format :: Dynamic -> Doc
format (Dynamic ControlMap
controls ControlFunctionMap
cfuncs Map Control Merger
cmerge PitchMap
pitches PSignal
pitch Environ
environ Warp
warp Scopes
scopes
InstrumentAliases
aliases ControlDamage
control_damage NoteDeriver -> NoteDeriver
_under_invert Inversion
inversion Maybe (Maybe PSignal, [Msg])
pitch_map
Maybe (BlockId, TrackId)
note_track Stack
stack Mode
mode) =
Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Dynamic"
[ (Text
"controls", ControlMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ControlMap
controls)
, (Text
"control_functions", ControlFunctionMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ControlFunctionMap
cfuncs)
, (Text
"control_merge_defaults", Map Control Merger -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map Control Merger
cmerge)
, (Text
"pitches", PitchMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format PitchMap
pitches)
, (Text
"pitch", PSignal -> Doc
forall a. Pretty a => a -> Doc
Pretty.format PSignal
pitch)
, (Text
"environ", Environ -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Environ
environ)
, (Text
"warp", Warp -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Warp
warp)
, (Text
"scopes", Scopes -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Scopes
scopes)
, (Text
"instrument_aliases", InstrumentAliases -> Doc
forall a. Pretty a => a -> Doc
Pretty.format InstrumentAliases
aliases)
, (Text
"control_damage", ControlDamage -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ControlDamage
control_damage)
, (Text
"inversion", Inversion -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Inversion
inversion)
, (Text
"pitch_map", Maybe (Maybe PSignal, [Msg]) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe (Maybe PSignal, [Msg])
pitch_map)
, (Text
"note_track", Maybe (BlockId, TrackId) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe (BlockId, TrackId)
note_track)
, (Text
"stack", Stack -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stack
stack)
, (Text
"mode", Mode -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Mode
mode)
]
instance DeepSeq.NFData Dynamic where
rnf :: Dynamic -> ()
rnf (Dynamic ControlMap
controls ControlFunctionMap
cfuncs Map Control Merger
cmerge PitchMap
pitches PSignal
pitch Environ
environ Warp
warp Scopes
_scopes
InstrumentAliases
aliases ControlDamage
control_damage NoteDeriver -> NoteDeriver
_under_invert Inversion
_inversion Maybe (Maybe PSignal, [Msg])
pitch_map
Maybe (BlockId, TrackId)
note_track Stack
stack Mode
_mode) =
ControlMap -> ()
forall a. NFData a => a -> ()
rnf ControlMap
controls () -> () -> ()
`seq` ControlFunctionMap -> ()
forall a. NFData a => a -> ()
rnf ControlFunctionMap
cfuncs () -> () -> ()
`seq` Map Control Merger -> ()
forall a. NFData a => a -> ()
rnf Map Control Merger
cmerge () -> () -> ()
`seq` PitchMap -> ()
forall a. NFData a => a -> ()
rnf PitchMap
pitches
() -> () -> ()
`seq` PSignal -> ()
forall a. NFData a => a -> ()
rnf PSignal
pitch () -> () -> ()
`seq` Environ -> ()
forall a. NFData a => a -> ()
rnf Environ
environ () -> () -> ()
`seq` Warp -> ()
forall a. NFData a => a -> ()
rnf Warp
warp () -> () -> ()
`seq` InstrumentAliases -> ()
forall a. NFData a => a -> ()
rnf InstrumentAliases
aliases
() -> () -> ()
`seq` ControlDamage -> ()
forall a. NFData a => a -> ()
rnf ControlDamage
control_damage () -> () -> ()
`seq` Maybe (Maybe PSignal, [Msg]) -> ()
forall a. NFData a => a -> ()
rnf Maybe (Maybe PSignal, [Msg])
pitch_map () -> () -> ()
`seq` Maybe (BlockId, TrackId) -> ()
forall a. NFData a => a -> ()
rnf Maybe (BlockId, TrackId)
note_track
() -> () -> ()
`seq` Stack -> ()
forall a. NFData a => a -> ()
rnf Stack
stack
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)
instance Show Builtins where show :: Builtins -> String
show Builtins
_ = String
"((Builtins))"
data CallMap call = CallMap {
forall call. CallMap call -> Map Symbol call
call_map :: Map Expr.Symbol call
, forall call. CallMap call -> [PatternCall call]
call_patterns :: [PatternCall call]
}
single_call :: Expr.Symbol -> call -> CallMap call
single_call :: forall call. Symbol -> call -> CallMap call
single_call Symbol
sym call
call = Map Symbol call -> [PatternCall call] -> CallMap call
forall call. Map Symbol call -> [PatternCall call] -> CallMap call
CallMap (Symbol -> call -> Map Symbol call
forall k a. k -> a -> Map k a
Map.singleton Symbol
sym call
call) []
instance Semigroup (CallMap call) where
CallMap Map Symbol call
a1 [PatternCall call]
a2 <> :: CallMap call -> CallMap call -> CallMap call
<> CallMap Map Symbol call
b1 [PatternCall call]
b2 = Map Symbol call -> [PatternCall call] -> CallMap call
forall call. Map Symbol call -> [PatternCall call] -> CallMap call
CallMap (Map Symbol call
a1Map Symbol call -> Map Symbol call -> Map Symbol call
forall a. Semigroup a => a -> a -> a
<>Map Symbol call
b1) ([PatternCall call]
a2[PatternCall call] -> [PatternCall call] -> [PatternCall call]
forall a. Semigroup a => a -> a -> a
<>[PatternCall call]
b2)
instance Monoid (CallMap call) where
mempty :: CallMap call
mempty = Map Symbol call -> [PatternCall call] -> CallMap call
forall call. Map Symbol call -> [PatternCall call] -> CallMap call
CallMap Map Symbol call
forall a. Monoid a => a
mempty [PatternCall call]
forall a. Monoid a => a
mempty
mappend :: CallMap call -> CallMap call -> CallMap call
mappend = CallMap call -> CallMap call -> CallMap call
forall a. Semigroup a => a -> a -> a
(<>)
instance Pretty (CallMap call) where
format :: CallMap call -> Doc
format (CallMap Map Symbol call
cmap [PatternCall call]
patterns) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"CallMap"
[ (Text
"map", [Symbol] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Map Symbol call -> [Symbol]
forall k a. Map k a -> [k]
Map.keys Map Symbol call
cmap))
, (Text
"patterns", [PatternCall call] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [PatternCall call]
patterns)
]
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)
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
}
s_generator :: ScopesT gen trans track val :-> gen
s_generator = (ScopesT gen trans track val -> gen)
-> ((gen -> gen)
-> ScopesT gen trans track val -> ScopesT gen trans track val)
-> ScopesT gen trans track val :-> gen
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens ScopesT gen trans track val -> gen
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator
(\gen -> gen
f ScopesT gen trans track val
r -> ScopesT gen trans track val
r { scopes_generator :: gen
scopes_generator = gen -> gen
f (ScopesT gen trans track val -> gen
forall gen trans track val. ScopesT gen trans track val -> gen
scopes_generator ScopesT gen trans track val
r) })
s_transformer :: ScopesT gen trans track val :-> trans
s_transformer = (ScopesT gen trans track val -> trans)
-> ((trans -> trans)
-> ScopesT gen trans track val -> ScopesT gen trans track val)
-> ScopesT gen trans track val :-> trans
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens ScopesT gen trans track val -> trans
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer
(\trans -> trans
f ScopesT gen trans track val
r -> ScopesT gen trans track val
r { scopes_transformer :: trans
scopes_transformer = trans -> trans
f (ScopesT gen trans track val -> trans
forall gen trans track val. ScopesT gen trans track val -> trans
scopes_transformer ScopesT gen trans track val
r) })
s_track :: ScopesT gen trans track val :-> track
s_track = (ScopesT gen trans track val -> track)
-> ((track -> track)
-> ScopesT gen trans track val -> ScopesT gen trans track val)
-> ScopesT gen trans track val :-> track
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens ScopesT gen trans track val -> track
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track
(\track -> track
f ScopesT gen trans track val
r -> ScopesT gen trans track val
r { scopes_track :: track
scopes_track = track -> track
f (ScopesT gen trans track val -> track
forall gen trans track val. ScopesT gen trans track val -> track
scopes_track ScopesT gen trans track val
r) })
s_val :: ScopesT gen trans track val :-> val
s_val = (ScopesT gen trans track val -> val)
-> ((val -> val)
-> ScopesT gen trans track val -> ScopesT gen trans track val)
-> ScopesT gen trans track val :-> val
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens ScopesT gen trans track val -> val
forall gen trans track val. ScopesT gen trans track val -> val
scopes_val
(\val -> val
f ScopesT gen trans track val
r -> ScopesT gen trans track val
r { scopes_val :: val
scopes_val = val -> val
f (ScopesT gen trans track val -> val
forall gen trans track val. ScopesT gen trans track val -> val
scopes_val ScopesT gen trans track val
r) })
instance (Pretty gen, Pretty trans, Pretty track, Pretty val) =>
Pretty (ScopesT gen trans track val) where
format :: ScopesT gen trans track val -> Doc
format (Scopes gen
gen trans
trans track
track val
val) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Scopes"
[ (Text
"generator", gen -> Doc
forall a. Pretty a => a -> Doc
Pretty.format gen
gen)
, (Text
"transformer", trans -> Doc
forall a. Pretty a => a -> Doc
Pretty.format trans
trans)
, (Text
"track", track -> Doc
forall a. Pretty a => a -> Doc
Pretty.format track
track)
, (Text
"val", val -> Doc
forall a. Pretty a => a -> Doc
Pretty.format val
val)
]
instance (Semigroup gen, Semigroup trans, Semigroup track, Semigroup val) =>
Semigroup (ScopesT gen trans track val) where
Scopes gen
a1 trans
a2 track
a3 val
a4 <> :: ScopesT gen trans track val
-> ScopesT gen trans track val -> ScopesT gen trans track val
<> Scopes gen
b1 trans
b2 track
b3 val
b4 =
gen -> trans -> track -> val -> ScopesT gen trans track val
forall gen trans track val.
gen -> trans -> track -> val -> ScopesT gen trans track val
Scopes (gen
a1gen -> gen -> gen
forall a. Semigroup a => a -> a -> a
<>gen
b1) (trans
a2trans -> trans -> trans
forall a. Semigroup a => a -> a -> a
<>trans
b2) (track
a3track -> track -> track
forall a. Semigroup a => a -> a -> a
<>track
b3) (val
a4val -> val -> val
forall a. Semigroup a => a -> a -> a
<>val
b4)
instance (Monoid gen, Monoid trans, Monoid track, Monoid val,
Semigroup gen, Semigroup trans, Semigroup track, Semigroup val) =>
Monoid (ScopesT gen trans track val) where
mempty :: ScopesT gen trans track val
mempty = gen -> trans -> track -> val -> ScopesT gen trans track val
forall gen trans track val.
gen -> trans -> track -> val -> ScopesT gen trans track val
Scopes gen
forall a. Monoid a => a
mempty trans
forall a. Monoid a => a
mempty track
forall a. Monoid a => a
mempty val
forall a. Monoid a => a
mempty
mappend :: ScopesT gen trans track val
-> ScopesT gen trans track val -> ScopesT gen trans track val
mappend = ScopesT gen trans track val
-> ScopesT gen trans track val -> ScopesT gen trans track val
forall a. Semigroup a => a -> a -> a
(<>)
data Scope note control pitch = Scope {
forall note control pitch. Scope note control pitch -> note
scope_note :: !note
, forall note control pitch. Scope note control pitch -> control
scope_control :: !control
, forall note control pitch. Scope note control pitch -> pitch
scope_pitch :: !pitch
}
s_note :: Scope note control pitch :-> note
s_note = (Scope note control pitch -> note)
-> ((note -> note)
-> Scope note control pitch -> Scope note control pitch)
-> Scope note control pitch :-> note
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Scope note control pitch -> note
forall note control pitch. Scope note control pitch -> note
scope_note
(\note -> note
f Scope note control pitch
r -> Scope note control pitch
r { scope_note :: note
scope_note = note -> note
f (Scope note control pitch -> note
forall note control pitch. Scope note control pitch -> note
scope_note Scope note control pitch
r) })
s_control :: Scope note control pitch :-> control
s_control = (Scope note control pitch -> control)
-> ((control -> control)
-> Scope note control pitch -> Scope note control pitch)
-> Scope note control pitch :-> control
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Scope note control pitch -> control
forall note control pitch. Scope note control pitch -> control
scope_control
(\control -> control
f Scope note control pitch
r -> Scope note control pitch
r { scope_control :: control
scope_control = control -> control
f (Scope note control pitch -> control
forall note control pitch. Scope note control pitch -> control
scope_control Scope note control pitch
r) })
s_pitch :: Scope note control pitch :-> pitch
s_pitch = (Scope note control pitch -> pitch)
-> ((pitch -> pitch)
-> Scope note control pitch -> Scope note control pitch)
-> Scope note control pitch :-> pitch
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Scope note control pitch -> pitch
forall note control pitch. Scope note control pitch -> pitch
scope_pitch
(\pitch -> pitch
f Scope note control pitch
r -> Scope note control pitch
r { scope_pitch :: pitch
scope_pitch = pitch -> pitch
f (Scope note control pitch -> pitch
forall note control pitch. Scope note control pitch -> pitch
scope_pitch Scope note control pitch
r) })
instance (Pretty note, Pretty control, Pretty pitch) =>
Pretty (Scope note control pitch) where
format :: Scope note control pitch -> Doc
format (Scope note
note control
control pitch
pitch) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Scope"
[ (Text
"note", note -> Doc
forall a. Pretty a => a -> Doc
Pretty.format note
note)
, (Text
"control", control -> Doc
forall a. Pretty a => a -> Doc
Pretty.format control
control)
, (Text
"pitch", pitch -> Doc
forall a. Pretty a => a -> Doc
Pretty.format pitch
pitch)
]
instance (Semigroup note, Semigroup control, Semigroup pitch) =>
Semigroup (Scope note control pitch) where
Scope note
a1 control
a2 pitch
a3 <> :: Scope note control pitch
-> Scope note control pitch -> Scope note control pitch
<> Scope note
b1 control
b2 pitch
b3 =
note -> control -> pitch -> Scope note control pitch
forall note control pitch.
note -> control -> pitch -> Scope note control pitch
Scope (note
a1note -> note -> note
forall a. Semigroup a => a -> a -> a
<>note
b1) (control
a2control -> control -> control
forall a. Semigroup a => a -> a -> a
<>control
b2) (pitch
a3pitch -> pitch -> pitch
forall a. Semigroup a => a -> a -> a
<>pitch
b3)
instance (Monoid note, Monoid control, Monoid pitch,
Semigroup note, Semigroup control, Semigroup pitch) =>
Monoid (Scope note control pitch) where
mempty :: Scope note control pitch
mempty = note -> control -> pitch -> Scope note control pitch
forall note control pitch.
note -> control -> pitch -> Scope note control pitch
Scope note
forall a. Monoid a => a
mempty control
forall a. Monoid a => a
mempty pitch
forall a. Monoid a => a
mempty
mappend :: Scope note control pitch
-> Scope note control pitch -> Scope note control pitch
mappend = Scope note control pitch
-> Scope note control pitch -> Scope note control pitch
forall a. Semigroup a => a -> a -> a
(<>)
instance DeepSeq.NFData (Scope a b c) where rnf :: Scope a b c -> ()
rnf Scope a b c
_ = ()
newtype ScopePriority call = ScopePriority (Map CallPriority (CallMap call))
deriving ([ScopePriority call] -> Doc
ScopePriority call -> Text
ScopePriority call -> Doc
(ScopePriority call -> Text)
-> (ScopePriority call -> Doc)
-> ([ScopePriority call] -> Doc)
-> Pretty (ScopePriority call)
forall call. [ScopePriority call] -> Doc
forall call. ScopePriority call -> Text
forall call. ScopePriority call -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [ScopePriority call] -> Doc
$cformatList :: forall call. [ScopePriority call] -> Doc
format :: ScopePriority call -> Doc
$cformat :: forall call. ScopePriority call -> Doc
pretty :: ScopePriority call -> Text
$cpretty :: forall call. ScopePriority call -> Text
Pretty)
instance Semigroup (ScopePriority call) where
ScopePriority Map CallPriority (CallMap call)
a <> :: ScopePriority call -> ScopePriority call -> ScopePriority call
<> ScopePriority Map CallPriority (CallMap call)
b = Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority (Map CallPriority (CallMap call)
-> Map CallPriority (CallMap call)
-> Map CallPriority (CallMap call)
forall k a. (Ord k, Monoid a) => Map k a -> Map k a -> Map k a
Maps.mappend Map CallPriority (CallMap call)
a Map CallPriority (CallMap call)
b)
instance Monoid (ScopePriority call) where
mempty :: ScopePriority call
mempty = Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority Map CallPriority (CallMap call)
forall a. Monoid a => a
mempty
mappend :: ScopePriority call -> ScopePriority call -> ScopePriority call
mappend = ScopePriority call -> ScopePriority call -> ScopePriority call
forall a. Semigroup a => a -> a -> a
(<>)
data CallPriority =
PrioOverride
| PrioInstrument
| PrioBlock
| PrioScale
| PrioBuiltin
deriving (Int -> CallPriority -> ShowS
[CallPriority] -> ShowS
CallPriority -> String
(Int -> CallPriority -> ShowS)
-> (CallPriority -> String)
-> ([CallPriority] -> ShowS)
-> Show CallPriority
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallPriority] -> ShowS
$cshowList :: [CallPriority] -> ShowS
show :: CallPriority -> String
$cshow :: CallPriority -> String
showsPrec :: Int -> CallPriority -> ShowS
$cshowsPrec :: Int -> CallPriority -> ShowS
Show, CallPriority -> CallPriority -> Bool
(CallPriority -> CallPriority -> Bool)
-> (CallPriority -> CallPriority -> Bool) -> Eq CallPriority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallPriority -> CallPriority -> Bool
$c/= :: CallPriority -> CallPriority -> Bool
== :: CallPriority -> CallPriority -> Bool
$c== :: CallPriority -> CallPriority -> Bool
Eq, Eq CallPriority
Eq CallPriority
-> (CallPriority -> CallPriority -> Ordering)
-> (CallPriority -> CallPriority -> Bool)
-> (CallPriority -> CallPriority -> Bool)
-> (CallPriority -> CallPriority -> Bool)
-> (CallPriority -> CallPriority -> Bool)
-> (CallPriority -> CallPriority -> CallPriority)
-> (CallPriority -> CallPriority -> CallPriority)
-> Ord CallPriority
CallPriority -> CallPriority -> Bool
CallPriority -> CallPriority -> Ordering
CallPriority -> CallPriority -> CallPriority
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CallPriority -> CallPriority -> CallPriority
$cmin :: CallPriority -> CallPriority -> CallPriority
max :: CallPriority -> CallPriority -> CallPriority
$cmax :: CallPriority -> CallPriority -> CallPriority
>= :: CallPriority -> CallPriority -> Bool
$c>= :: CallPriority -> CallPriority -> Bool
> :: CallPriority -> CallPriority -> Bool
$c> :: CallPriority -> CallPriority -> Bool
<= :: CallPriority -> CallPriority -> Bool
$c<= :: CallPriority -> CallPriority -> Bool
< :: CallPriority -> CallPriority -> Bool
$c< :: CallPriority -> CallPriority -> Bool
compare :: CallPriority -> CallPriority -> Ordering
$ccompare :: CallPriority -> CallPriority -> Ordering
Ord)
instance Pretty CallPriority where pretty :: CallPriority -> Text
pretty = CallPriority -> Text
forall a. Show a => a -> Text
showt
scope_priority :: [(CallPriority, CallMap call)] -> ScopePriority call
scope_priority :: forall call. [(CallPriority, CallMap call)] -> ScopePriority call
scope_priority = Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority (Map CallPriority (CallMap call) -> ScopePriority call)
-> ([(CallPriority, CallMap call)]
-> Map CallPriority (CallMap call))
-> [(CallPriority, CallMap call)]
-> ScopePriority call
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CallPriority, CallMap call)] -> Map CallPriority (CallMap call)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
lookup_priority :: CallPriority -> ScopePriority call -> CallMap call
lookup_priority :: forall call. CallPriority -> ScopePriority call -> CallMap call
lookup_priority CallPriority
prio (ScopePriority Map CallPriority (CallMap call)
scopes) =
CallMap call
-> CallPriority -> Map CallPriority (CallMap call) -> CallMap call
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault CallMap call
forall a. Monoid a => a
mempty CallPriority
prio Map CallPriority (CallMap call)
scopes
add_priority :: CallPriority -> CallMap call -> ScopePriority call
-> ScopePriority call
add_priority :: forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
add_priority CallPriority
prio CallMap call
cmap (ScopePriority Map CallPriority (CallMap call)
scopes) =
Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority (Map CallPriority (CallMap call) -> ScopePriority call)
-> Map CallPriority (CallMap call) -> ScopePriority call
forall a b. (a -> b) -> a -> b
$ (CallMap call -> CallMap call -> CallMap call)
-> CallPriority
-> CallMap call
-> Map CallPriority (CallMap call)
-> Map CallPriority (CallMap call)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith CallMap call -> CallMap call -> CallMap call
forall a. Semigroup a => a -> a -> a
(<>) CallPriority
prio CallMap call
cmap Map CallPriority (CallMap call)
scopes
replace_priority :: CallPriority -> CallMap call -> ScopePriority call
-> ScopePriority call
replace_priority :: forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
replace_priority CallPriority
prio CallMap call
cmap (ScopePriority Map CallPriority (CallMap call)
scopes) =
Map CallPriority (CallMap call) -> ScopePriority call
forall call. Map CallPriority (CallMap call) -> ScopePriority call
ScopePriority (Map CallPriority (CallMap call) -> ScopePriority call)
-> Map CallPriority (CallMap call) -> ScopePriority call
forall a b. (a -> b) -> a -> b
$ CallPriority
-> CallMap call
-> Map CallPriority (CallMap call)
-> Map CallPriority (CallMap call)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CallPriority
prio CallMap call
cmap Map CallPriority (CallMap call)
scopes
data DocumentedCall = DocumentedCall !CallName !CallDoc
extract_doc :: Call d -> DocumentedCall
Call d
call = CallName -> CallDoc -> DocumentedCall
DocumentedCall (Call d -> CallName
forall func. Call func -> CallName
call_name Call d
call) (Call d -> CallDoc
forall func. Call func -> CallDoc
call_doc Call d
call)
extract_val_doc :: ValCall -> DocumentedCall
ValCall
vcall = CallName -> CallDoc -> DocumentedCall
DocumentedCall (ValCall -> CallName
vcall_name ValCall
vcall) (ValCall -> CallDoc
vcall_doc ValCall
vcall)
extract_track_doc :: TrackCall d -> DocumentedCall
TrackCall d
tcall = CallName -> CallDoc -> DocumentedCall
DocumentedCall (TrackCall d -> CallName
forall d. TrackCall d -> CallName
tcall_name TrackCall d
tcall) (TrackCall d -> CallDoc
forall d. TrackCall d -> CallDoc
tcall_doc TrackCall d
tcall)
data TrackCall d = TrackCall {
forall d. TrackCall d -> CallName
tcall_name :: !CallName
, forall d. TrackCall d -> CallDoc
tcall_doc :: !CallDoc
, forall d. TrackCall d -> TrackCallFunc d
tcall_func :: !(TrackCallFunc d)
}
type TrackCallFunc d =
TrackTree.Track -> Deriver (ScoreT.Typed ScoreT.Control, d)
instance Show (TrackCall d) where
show :: TrackCall d -> String
show TrackCall d
tcall = String
"((TrackCall " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallName -> String
forall a. Show a => a -> String
show (TrackCall d -> CallName
forall d. TrackCall d -> CallName
tcall_name TrackCall d
tcall) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"))"
instance Pretty (TrackCall d) where
pretty :: TrackCall d -> Text
pretty = CallName -> Text
forall a. Pretty a => a -> Text
pretty (CallName -> Text)
-> (TrackCall d -> CallName) -> TrackCall d -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackCall d -> CallName
forall d. TrackCall d -> CallName
tcall_name
track_call :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
-> TrackCallFunc d -> TrackCall d
track_call :: forall d.
Module -> CallName -> Tags -> Doc -> TrackCallFunc d -> TrackCall d
track_call Module
module_ CallName
name Tags
tags Doc
doc TrackCallFunc d
call = TrackCall
{ tcall_name :: CallName
tcall_name = CallName
name
, tcall_doc :: CallDoc
tcall_doc = CallDoc
{ cdoc_module :: Module
cdoc_module = Module
module_
, cdoc_tags :: Tags
cdoc_tags = Tags
tags
, cdoc_doc :: Doc
cdoc_doc = Doc
doc
, cdoc_args :: [ArgDoc]
cdoc_args = [ArgDoc]
forall a. Monoid a => a
mempty
}
, tcall_func :: TrackCallFunc d
tcall_func = TrackCallFunc d
call
}
lookup_call :: Callable call => Expr.Symbol -> Deriver (Maybe call)
lookup_call :: forall call. Callable call => Symbol -> Deriver (Maybe call)
lookup_call = (Scopes -> ScopePriority call)
-> (Builtins -> ModuleMap call) -> Symbol -> Deriver (Maybe call)
forall call.
(Scopes -> ScopePriority call)
-> (Builtins -> ModuleMap call) -> Symbol -> Deriver (Maybe call)
lookup_call_with Scopes -> ScopePriority call
forall call. Callable call => Scopes -> ScopePriority call
get_scopes_scope Builtins -> ModuleMap call
forall call. Callable call => Builtins -> ModuleMap call
get_builtins_scope
lookup_call_with :: (Scopes -> ScopePriority call)
-> (Builtins -> ModuleMap call) -> Expr.Symbol -> Deriver (Maybe call)
lookup_call_with :: forall call.
(Scopes -> ScopePriority call)
-> (Builtins -> ModuleMap call) -> Symbol -> Deriver (Maybe call)
lookup_call_with Scopes -> ScopePriority call
get_scopes Builtins -> ModuleMap call
get_builtins Symbol
sym = do
[CallMap call]
cmaps <- (Scopes -> ScopePriority call) -> Deriver [CallMap call]
forall call.
(Scopes -> ScopePriority call) -> Deriver [CallMap call]
get_call_maps Scopes -> ScopePriority call
get_scopes
[CallMap call] -> Symbol -> Deriver (Maybe call)
forall call. [CallMap call] -> Symbol -> Deriver (Maybe call)
lookup_call_maps [CallMap call]
cmaps Symbol
sym Deriver (Maybe call)
-> (Maybe call -> Deriver (Maybe call)) -> Deriver (Maybe call)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just call
call -> Maybe call -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe call -> Deriver (Maybe call))
-> Maybe call -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$ call -> Maybe call
forall a. a -> Maybe a
Just call
call
Maybe call
Nothing -> case Symbol -> Maybe (Module, Symbol)
split_qualified Symbol
sym of
Maybe (Module, Symbol)
Nothing -> Maybe call -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe call
forall a. Maybe a
Nothing
Just (Module
mod, Symbol
sym) -> (Builtins -> ModuleMap call)
-> Module -> Symbol -> Deriver (Maybe call)
forall call.
(Builtins -> ModuleMap call)
-> Module -> Symbol -> Deriver (Maybe call)
lookup_qualified Builtins -> ModuleMap call
get_builtins Module
mod Symbol
sym
split_qualified :: Expr.Symbol -> Maybe (Module.Module, Expr.Symbol)
split_qualified :: Symbol -> Maybe (Module, Symbol)
split_qualified Symbol
sym
| Text -> Bool
Text.null Text
mod Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
name = Maybe (Module, Symbol)
forall a. Maybe a
Nothing
| Bool
otherwise = (Module, Symbol) -> Maybe (Module, Symbol)
forall a. a -> Maybe a
Just (Text -> Module
Module.Module (Int -> Text -> Text
Text.dropEnd Int
1 Text
mod), Text -> Symbol
Expr.Symbol Text
name)
where (Text
mod, Text
name) = Text -> Text -> (Text, Text)
Text.breakOnEnd Text
"." (Symbol -> Text
Expr.unsym Symbol
sym)
lookup_qualified :: (Builtins -> ModuleMap call)
-> Module.Module -> Expr.Symbol -> Deriver (Maybe call)
lookup_qualified :: forall call.
(Builtins -> ModuleMap call)
-> Module -> Symbol -> Deriver (Maybe call)
lookup_qualified Builtins -> ModuleMap call
get_scope Module
module_ Symbol
sym = do
ModuleMap call
by_module <- (State -> ModuleMap call) -> Deriver State Error (ModuleMap call)
forall st a err. (st -> a) -> Deriver st err a
gets ((State -> ModuleMap call) -> Deriver State Error (ModuleMap call))
-> (State -> ModuleMap call)
-> Deriver State Error (ModuleMap call)
forall a b. (a -> b) -> a -> b
$ Builtins -> ModuleMap call
get_scope (Builtins -> ModuleMap call)
-> (State -> Builtins) -> State -> ModuleMap call
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constant -> Builtins
state_builtins (Constant -> Builtins) -> (State -> Constant) -> State -> Builtins
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant
Maybe call -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe call -> Deriver (Maybe call))
-> Maybe call -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$ do
CallMap call
cmap <- Module -> ModuleMap call -> Maybe (CallMap call)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
module_ ModuleMap call
by_module
Symbol -> Map Symbol call -> Maybe call
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
sym (CallMap call -> Map Symbol call
forall call. CallMap call -> Map Symbol call
call_map CallMap call
cmap)
get_call_maps :: (Scopes -> ScopePriority call) -> Deriver [CallMap call]
get_call_maps :: forall call.
(Scopes -> ScopePriority call) -> Deriver [CallMap call]
get_call_maps Scopes -> ScopePriority call
get = do
ScopePriority Map CallPriority (CallMap call)
scopes <- (State -> ScopePriority call)
-> Deriver State Error (ScopePriority call)
forall st a err. (st -> a) -> Deriver st err a
gets ((State -> ScopePriority call)
-> Deriver State Error (ScopePriority call))
-> (State -> ScopePriority call)
-> Deriver State Error (ScopePriority call)
forall a b. (a -> b) -> a -> b
$ Scopes -> ScopePriority call
get (Scopes -> ScopePriority call)
-> (State -> Scopes) -> State -> ScopePriority call
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Scopes
state_scopes (Dynamic -> Scopes) -> (State -> Dynamic) -> State -> Scopes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic
[CallMap call] -> Deriver [CallMap call]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CallMap call] -> Deriver [CallMap call])
-> [CallMap call] -> Deriver [CallMap call]
forall a b. (a -> b) -> a -> b
$ Map CallPriority (CallMap call) -> [CallMap call]
forall k a. Map k a -> [a]
Map.elems Map CallPriority (CallMap call)
scopes
lookup_call_maps :: [CallMap call] -> Expr.Symbol -> Deriver (Maybe call)
lookup_call_maps :: forall call. [CallMap call] -> Symbol -> Deriver (Maybe call)
lookup_call_maps [CallMap call]
lookups Symbol
sym = [Deriver State Error (Maybe call)]
-> Deriver State Error (Maybe call)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts ([Deriver State Error (Maybe call)]
-> Deriver State Error (Maybe call))
-> [Deriver State Error (Maybe call)]
-> Deriver State Error (Maybe call)
forall a b. (a -> b) -> a -> b
$ (CallMap call -> Deriver State Error (Maybe call))
-> [CallMap call] -> [Deriver State Error (Maybe call)]
forall a b. (a -> b) -> [a] -> [b]
map (Symbol -> CallMap call -> Deriver State Error (Maybe call)
forall call. Symbol -> CallMap call -> Deriver (Maybe call)
lookup_call_map Symbol
sym) [CallMap call]
lookups
lookup_call_map :: Expr.Symbol -> CallMap call -> Deriver (Maybe call)
lookup_call_map :: forall call. Symbol -> CallMap call -> Deriver (Maybe call)
lookup_call_map Symbol
sym (CallMap Map Symbol call
cmap [PatternCall call]
patterns) = case Symbol -> Map Symbol call -> Maybe call
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
sym Map Symbol call
cmap of
Just call
call -> Maybe call -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe call -> Deriver (Maybe call))
-> Maybe call -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$ call -> Maybe call
forall a. a -> Maybe a
Just call
call
Maybe call
Nothing -> [Deriver (Maybe call)] -> Deriver (Maybe call)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts ([Deriver (Maybe call)] -> Deriver (Maybe call))
-> [Deriver (Maybe call)] -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$ (PatternCall call -> Deriver (Maybe call))
-> [PatternCall call] -> [Deriver (Maybe call)]
forall a b. (a -> b) -> [a] -> [b]
map (((Symbol -> Deriver (Maybe call)) -> Symbol -> Deriver (Maybe call)
forall a b. (a -> b) -> a -> b
$Symbol
sym) ((Symbol -> Deriver (Maybe call)) -> Deriver (Maybe call))
-> (PatternCall call -> Symbol -> Deriver (Maybe call))
-> PatternCall call
-> Deriver (Maybe call)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternCall call -> Symbol -> Deriver (Maybe call)
forall call. PatternCall call -> Symbol -> Deriver (Maybe call)
pat_function) [PatternCall call]
patterns
data Mode =
Normal
| ScoreDurationQuery | RealDurationQuery
| Lilypond !Lilypond.Types.Config
deriving (Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)
instance Pretty Mode where
format :: Mode -> Doc
format (Lilypond Config
config) = Doc
"Lilypond" Doc -> Doc -> Doc
Pretty.<+> Config -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Config
config
format Mode
mode = Text -> Doc
Pretty.text (Mode -> Text
forall a. Show a => a -> Text
showt Mode
mode)
data Constant = Constant {
Constant -> State
state_ui :: !Ui.State
, Constant -> Builtins
state_builtins :: !Builtins
, Constant -> Map Symbol Merger
state_mergers :: !(Map Expr.Symbol Merger)
, Constant -> LookupScale
state_lookup_scale :: !LookupScale
, Constant -> Instrument -> Either Text Instrument
state_lookup_instrument :: !(ScoreT.Instrument -> Either Text Instrument)
, Constant -> Cache
state_cache :: !Cache
, Constant -> ScoreDamage
state_score_damage :: !ScoreDamage
}
initial_constant :: Ui.State -> Builtins -> LookupScale
-> (ScoreT.Instrument -> Either Text Instrument) -> Cache -> ScoreDamage
-> Constant
initial_constant :: State
-> Builtins
-> LookupScale
-> (Instrument -> Either Text Instrument)
-> Cache
-> ScoreDamage
-> Constant
initial_constant State
ui_state Builtins
builtins LookupScale
lookup_scale Instrument -> Either Text Instrument
lookup_inst Cache
cache ScoreDamage
score_damage =
Constant
{ state_ui :: State
state_ui = State
ui_state
, state_builtins :: Builtins
state_builtins = Builtins
builtins
, state_mergers :: Map Symbol Merger
state_mergers = Map Symbol Merger
mergers
, state_lookup_scale :: LookupScale
state_lookup_scale = LookupScale
lookup_scale
, state_lookup_instrument :: Instrument -> Either Text Instrument
state_lookup_instrument = Instrument -> Either Text Instrument
lookup_inst
, state_cache :: Cache
state_cache = ScoreDamage -> Cache -> Cache
invalidate_damaged ScoreDamage
score_damage Cache
cache
, state_score_damage :: ScoreDamage
state_score_damage = ScoreDamage
score_damage
}
data Instrument = Instrument {
Instrument -> InstrumentCalls
inst_calls :: !InstrumentCalls
, Instrument -> Environ
inst_environ :: !DeriveT.Environ
, Instrument -> ControlValMap
inst_controls :: !ScoreT.ControlValMap
, Instrument -> [Attributes]
inst_attributes :: ![Attrs.Attributes]
, Instrument -> Set Text
inst_elements :: !(Set Shared.Note.Element)
} deriving (Int -> Instrument -> ShowS
[Instrument] -> ShowS
Instrument -> String
(Int -> Instrument -> ShowS)
-> (Instrument -> String)
-> ([Instrument] -> ShowS)
-> Show Instrument
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instrument] -> ShowS
$cshowList :: [Instrument] -> ShowS
show :: Instrument -> String
$cshow :: Instrument -> String
showsPrec :: Int -> Instrument -> ShowS
$cshowsPrec :: Int -> Instrument -> ShowS
Show)
type InstrumentCalls = ScopesT
(CallMap (Generator Note))
(CallMap (Transformer Note))
(CallMap (TrackCall Note))
(CallMap ValCall)
instance Show InstrumentCalls where
show :: InstrumentCalls -> String
show (Scopes CallMap (Generator Event)
gen CallMap (Transformer Event)
trans CallMap (TrackCall Event)
tracks CallMap ValCall
val) =
String
"((InstrumentCalls "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [CallMap (Generator Event) -> String
forall a. Pretty a => a -> String
prettys CallMap (Generator Event)
gen, CallMap (Transformer Event) -> String
forall a. Pretty a => a -> String
prettys CallMap (Transformer Event)
trans, CallMap (TrackCall Event) -> String
forall a. Pretty a => a -> String
prettys CallMap (TrackCall Event)
tracks, CallMap ValCall -> String
forall a. Pretty a => a -> String
prettys CallMap ValCall
val]
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"))"
data Merge = DefaultMerge
| Merge !Merger
deriving (Int -> Merge -> ShowS
[Merge] -> ShowS
Merge -> String
(Int -> Merge -> ShowS)
-> (Merge -> String) -> ([Merge] -> ShowS) -> Show Merge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Merge] -> ShowS
$cshowList :: [Merge] -> ShowS
show :: Merge -> String
$cshow :: Merge -> String
showsPrec :: Int -> Merge -> ShowS
$cshowsPrec :: Int -> Merge -> ShowS
Show)
instance Pretty Merge where pretty :: Merge -> Text
pretty = Merge -> Text
forall a. Show a => a -> Text
showt
instance DeepSeq.NFData Merge where rnf :: Merge -> ()
rnf Merge
_ = ()
data Merger =
Merger !Text !(Signal.Control -> Signal.Control -> Signal.Control) !Signal.Y
| Set
| Unset
instance ShowVal.ShowVal Merger where
show_val :: Merger -> Text
show_val Merger
Set = Text
"set"
show_val Merger
Unset = Text
"unset"
show_val (Merger Text
name Control -> Control -> Control
_ Y
_) = Text
name
instance Pretty Merger where pretty :: Merger -> Text
pretty = Merger -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val
instance Show Merger where
show :: Merger -> String
show Merger
merger = String
"((Merger " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
untxt (Merger -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Merger
merger) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"))"
instance DeepSeq.NFData Merger where rnf :: Merger -> ()
rnf Merger
_ = ()
mergers :: Map Expr.Symbol Merger
mergers :: Map Symbol Merger
mergers = [(Symbol, Merger)] -> Map Symbol Merger
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Symbol, Merger)] -> Map Symbol Merger)
-> [(Symbol, Merger)] -> Map Symbol Merger
forall a b. (a -> b) -> a -> b
$ (Merger -> (Symbol, Merger)) -> [Merger] -> [(Symbol, Merger)]
forall a b. (a -> b) -> [a] -> [b]
map Merger -> (Symbol, Merger)
forall {b}. ShowVal b => b -> (Symbol, b)
to_pair
[ Merger
Set, Merger
merge_add, Merger
merge_sub, Merger
merge_mul, Merger
merge_scale
]
where to_pair :: b -> (Symbol, b)
to_pair b
merger = (Text -> Symbol
Expr.Symbol (b -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val b
merger), b
merger)
merge_add, merge_sub, merge_mul :: Merger
merge_add :: Merger
merge_add = Text -> (Control -> Control -> Control) -> Y -> Merger
Merger Text
"add" Control -> Control -> Control
Signal.sig_add Y
0
merge_sub :: Merger
merge_sub = Text -> (Control -> Control -> Control) -> Y -> Merger
Merger Text
"sub" Control -> Control -> Control
Signal.sig_subtract Y
0
merge_mul :: Merger
merge_mul = Text -> (Control -> Control -> Control) -> Y -> Merger
Merger Text
"mul" Control -> Control -> Control
Signal.sig_multiply Y
1
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
data Collect = Collect {
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
, Collect -> TrackDynamic
collect_track_dynamic_inverted :: !TrackDynamic
, Collect -> BlockDeps
collect_block_deps :: !BlockDeps
, 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 {
CacheStats -> [(Either BlockId TrackId, (RealTime, RealTime))]
cstats_hits :: ![(Either BlockId TrackId, (RealTime, RealTime))]
} deriving (CacheStats -> CacheStats -> Bool
(CacheStats -> CacheStats -> Bool)
-> (CacheStats -> CacheStats -> Bool) -> Eq CacheStats
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheStats -> CacheStats -> Bool
$c/= :: CacheStats -> CacheStats -> Bool
== :: CacheStats -> CacheStats -> Bool
$c== :: CacheStats -> CacheStats -> Bool
Eq, Int -> CacheStats -> ShowS
[CacheStats] -> ShowS
CacheStats -> String
(Int -> CacheStats -> ShowS)
-> (CacheStats -> String)
-> ([CacheStats] -> ShowS)
-> Show CacheStats
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheStats] -> ShowS
$cshowList :: [CacheStats] -> ShowS
show :: CacheStats -> String
$cshow :: CacheStats -> String
showsPrec :: Int -> CacheStats -> ShowS
$cshowsPrec :: Int -> CacheStats -> ShowS
Show)
instance Pretty CacheStats where
format :: CacheStats -> Doc
format (CacheStats [(Either BlockId TrackId, (RealTime, RealTime))]
hits) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"CacheStats"
[ (Text
"hits", [(Either BlockId TrackId, (RealTime, RealTime))] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [(Either BlockId TrackId, (RealTime, RealTime))]
hits)
]
instance Semigroup CacheStats where
CacheStats [(Either BlockId TrackId, (RealTime, RealTime))]
hits1 <> :: CacheStats -> CacheStats -> CacheStats
<> CacheStats [(Either BlockId TrackId, (RealTime, RealTime))]
hits2 = [(Either BlockId TrackId, (RealTime, RealTime))] -> CacheStats
CacheStats ([(Either BlockId TrackId, (RealTime, RealTime))]
hits1 [(Either BlockId TrackId, (RealTime, RealTime))]
-> [(Either BlockId TrackId, (RealTime, RealTime))]
-> [(Either BlockId TrackId, (RealTime, RealTime))]
forall a. Semigroup a => a -> a -> a
<> [(Either BlockId TrackId, (RealTime, RealTime))]
hits2)
instance Monoid CacheStats where
mempty :: CacheStats
mempty = [(Either BlockId TrackId, (RealTime, RealTime))] -> CacheStats
CacheStats [(Either BlockId TrackId, (RealTime, RealTime))]
forall a. Monoid a => a
mempty
mappend :: CacheStats -> CacheStats -> CacheStats
mappend = CacheStats -> CacheStats -> CacheStats
forall a. Semigroup a => a -> a -> a
(<>)
type SignalFragments = Map (BlockId, TrackId) (Map TrackTime Signal.Control)
instance Pretty Collect where
format :: Collect -> Doc
format (Collect WarpMap
warp_map TrackSignals
tsigs SignalFragments
frags TrackDynamic
trackdyn TrackDynamic
trackdyn_inv BlockDeps
deps
Cache
cache CacheStats
cache_stats [Integrated]
integrated [ControlMod]
cmods CallDuration ScoreTime
call_dur CallDuration RealTime
call_end) =
Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Collect"
[ (Text
"warp_map", WarpMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format WarpMap
warp_map)
, (Text
"track_signals", TrackSignals -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackSignals
tsigs)
, (Text
"signal_fragments", SignalFragments -> Doc
forall a. Pretty a => a -> Doc
Pretty.format SignalFragments
frags)
, (Text
"track_dynamic", TrackDynamic -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackDynamic
trackdyn)
, (Text
"track_dynamic_inverted", TrackDynamic -> Doc
forall a. Pretty a => a -> Doc
Pretty.format TrackDynamic
trackdyn_inv)
, (Text
"block_deps", BlockDeps -> Doc
forall a. Pretty a => a -> Doc
Pretty.format BlockDeps
deps)
, (Text
"cache", Cache -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Cache
cache)
, (Text
"cache_stats", CacheStats -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CacheStats
cache_stats)
, (Text
"integrated", [Integrated] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Integrated]
integrated)
, (Text
"control_mods", [ControlMod] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [ControlMod]
cmods)
, (Text
"call duration", CallDuration ScoreTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CallDuration ScoreTime
call_dur)
, (Text
"call end", CallDuration RealTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CallDuration RealTime
call_end)
]
instance Semigroup Collect where
<> :: Collect -> Collect -> Collect
(<>) (Collect WarpMap
warps1 TrackSignals
tsigs1 SignalFragments
frags1 TrackDynamic
trackdyn1 TrackDynamic
trackdyn_inv1 BlockDeps
deps1
Cache
cache1 CacheStats
cstats1 [Integrated]
integrated1 [ControlMod]
cmods1 CallDuration ScoreTime
cdur1 CallDuration RealTime
cend1)
(Collect WarpMap
warps2 TrackSignals
tsigs2 SignalFragments
frags2 TrackDynamic
trackdyn2 TrackDynamic
trackdyn_inv2 BlockDeps
deps2
Cache
cache2 CacheStats
cstats2 [Integrated]
integrated2 [ControlMod]
cmods2 CallDuration ScoreTime
cdur2 CallDuration RealTime
cend2) =
WarpMap
-> TrackSignals
-> SignalFragments
-> TrackDynamic
-> TrackDynamic
-> BlockDeps
-> Cache
-> CacheStats
-> [Integrated]
-> [ControlMod]
-> CallDuration ScoreTime
-> CallDuration RealTime
-> Collect
Collect (WarpMap
warps1 WarpMap -> WarpMap -> WarpMap
forall a. Semigroup a => a -> a -> a
<> WarpMap
warps2)
(TrackSignals
tsigs1 TrackSignals -> TrackSignals -> TrackSignals
forall a. Semigroup a => a -> a -> a
<> TrackSignals
tsigs2) ((Map ScoreTime Control
-> Map ScoreTime Control -> Map ScoreTime Control)
-> SignalFragments -> SignalFragments -> SignalFragments
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Map ScoreTime Control
-> Map ScoreTime Control -> Map ScoreTime Control
forall a. Semigroup a => a -> a -> a
(<>) SignalFragments
frags1 SignalFragments
frags2)
(TrackDynamic
trackdyn1 TrackDynamic -> TrackDynamic -> TrackDynamic
forall a. Semigroup a => a -> a -> a
<> TrackDynamic
trackdyn2) (TrackDynamic
trackdyn_inv1 TrackDynamic -> TrackDynamic -> TrackDynamic
forall a. Semigroup a => a -> a -> a
<> TrackDynamic
trackdyn_inv2)
(BlockDeps
deps1 BlockDeps -> BlockDeps -> BlockDeps
forall a. Semigroup a => a -> a -> a
<> BlockDeps
deps2) (Cache
cache1 Cache -> Cache -> Cache
forall a. Semigroup a => a -> a -> a
<> Cache
cache2) (CacheStats
cstats1 CacheStats -> CacheStats -> CacheStats
forall a. Semigroup a => a -> a -> a
<> CacheStats
cstats2)
([Integrated]
integrated1 [Integrated] -> [Integrated] -> [Integrated]
forall a. Semigroup a => a -> a -> a
<> [Integrated]
integrated2) ([ControlMod]
cmods1 [ControlMod] -> [ControlMod] -> [ControlMod]
forall a. Semigroup a => a -> a -> a
<> [ControlMod]
cmods2) (CallDuration ScoreTime
cdur1 CallDuration ScoreTime
-> CallDuration ScoreTime -> CallDuration ScoreTime
forall a. Semigroup a => a -> a -> a
<> CallDuration ScoreTime
cdur2)
(CallDuration RealTime
cend1 CallDuration RealTime
-> CallDuration RealTime -> CallDuration RealTime
forall a. Semigroup a => a -> a -> a
<> CallDuration RealTime
cend2)
instance Monoid Collect where
mempty :: Collect
mempty = WarpMap
-> TrackSignals
-> SignalFragments
-> TrackDynamic
-> TrackDynamic
-> BlockDeps
-> Cache
-> CacheStats
-> [Integrated]
-> [ControlMod]
-> CallDuration ScoreTime
-> CallDuration RealTime
-> Collect
Collect WarpMap
forall a. Monoid a => a
mempty TrackSignals
forall a. Monoid a => a
mempty SignalFragments
forall a. Monoid a => a
mempty TrackDynamic
forall a. Monoid a => a
mempty TrackDynamic
forall a. Monoid a => a
mempty BlockDeps
forall a. Monoid a => a
mempty Cache
forall a. Monoid a => a
mempty CacheStats
forall a. Monoid a => a
mempty
[Integrated]
forall a. Monoid a => a
mempty [ControlMod]
forall a. Monoid a => a
mempty CallDuration ScoreTime
forall a. Monoid a => a
mempty CallDuration RealTime
forall a. Monoid a => a
mempty
mappend :: Collect -> Collect -> Collect
mappend = Collect -> Collect -> Collect
forall a. Semigroup a => a -> a -> a
(<>)
instance DeepSeq.NFData Collect where
rnf :: Collect -> ()
rnf (Collect WarpMap
warp_map TrackSignals
frags SignalFragments
tsigs TrackDynamic
track_dyn TrackDynamic
track_dyn_inv BlockDeps
local_dep
Cache
cache CacheStats
_cstats [Integrated]
integrated [ControlMod]
_cmods CallDuration ScoreTime
_cdur CallDuration RealTime
_cend) =
WarpMap -> ()
forall a. NFData a => a -> ()
rnf WarpMap
warp_map () -> () -> ()
`seq` TrackSignals -> ()
forall a. NFData a => a -> ()
rnf TrackSignals
frags () -> () -> ()
`seq` SignalFragments -> ()
forall a. NFData a => a -> ()
rnf SignalFragments
tsigs () -> () -> ()
`seq` TrackDynamic -> ()
forall a. NFData a => a -> ()
rnf TrackDynamic
track_dyn
() -> () -> ()
`seq` TrackDynamic -> ()
forall a. NFData a => a -> ()
rnf TrackDynamic
track_dyn_inv () -> () -> ()
`seq` BlockDeps -> ()
forall a. NFData a => a -> ()
rnf BlockDeps
local_dep () -> () -> ()
`seq` Cache -> ()
forall a. NFData a => a -> ()
rnf Cache
cache
() -> () -> ()
`seq` [Integrated] -> ()
forall a. NFData a => a -> ()
rnf [Integrated]
integrated
data ControlMod = ControlMod !ScoreT.Control !Signal.Control !Merger
deriving (Int -> ControlMod -> ShowS
[ControlMod] -> ShowS
ControlMod -> String
(Int -> ControlMod -> ShowS)
-> (ControlMod -> String)
-> ([ControlMod] -> ShowS)
-> Show ControlMod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlMod] -> ShowS
$cshowList :: [ControlMod] -> ShowS
show :: ControlMod -> String
$cshow :: ControlMod -> String
showsPrec :: Int -> ControlMod -> ShowS
$cshowsPrec :: Int -> ControlMod -> ShowS
Show)
instance Pretty ControlMod where
format :: ControlMod -> Doc
format (ControlMod Control
control Control
signal Merger
merge) =
Text -> [Doc] -> Doc
Pretty.constructor Text
"ControlMod"
[Control -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Control
control, Control -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Control
signal, Merger -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Merger
merge]
data Integrated = Integrated {
Integrated -> Either BlockId TrackId
integrated_source :: !(Either BlockId TrackId)
, Integrated -> Stream Event
integrated_events :: !(Stream.Stream Score.Event)
} deriving (Int -> Integrated -> ShowS
[Integrated] -> ShowS
Integrated -> String
(Int -> Integrated -> ShowS)
-> (Integrated -> String)
-> ([Integrated] -> ShowS)
-> Show Integrated
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Integrated] -> ShowS
$cshowList :: [Integrated] -> ShowS
show :: Integrated -> String
$cshow :: Integrated -> String
showsPrec :: Int -> Integrated -> ShowS
$cshowsPrec :: Int -> Integrated -> ShowS
Show)
instance Pretty Integrated where
format :: Integrated -> Doc
format (Integrated Either BlockId TrackId
source Stream Event
events) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Integrated"
[ (Text
"source", Either BlockId TrackId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Either BlockId TrackId
source)
, (Text
"events", Stream Event -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stream Event
events)
]
instance DeepSeq.NFData Integrated where
rnf :: Integrated -> ()
rnf (Integrated Either BlockId TrackId
source Stream Event
events) = Either BlockId TrackId -> ()
forall a. NFData a => a -> ()
rnf Either BlockId TrackId
source () -> () -> ()
`seq` Stream Event -> ()
forall a. NFData a => a -> ()
rnf Stream Event
events
type TrackDynamic = Map (BlockId, TrackId) Dynamic
data CallDuration a = Unknown | CallDuration !a
deriving (CallDuration a -> CallDuration a -> Bool
(CallDuration a -> CallDuration a -> Bool)
-> (CallDuration a -> CallDuration a -> Bool)
-> Eq (CallDuration a)
forall a. Eq a => CallDuration a -> CallDuration a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallDuration a -> CallDuration a -> Bool
$c/= :: forall a. Eq a => CallDuration a -> CallDuration a -> Bool
== :: CallDuration a -> CallDuration a -> Bool
$c== :: forall a. Eq a => CallDuration a -> CallDuration a -> Bool
Eq, Int -> CallDuration a -> ShowS
[CallDuration a] -> ShowS
CallDuration a -> String
(Int -> CallDuration a -> ShowS)
-> (CallDuration a -> String)
-> ([CallDuration a] -> ShowS)
-> Show (CallDuration a)
forall a. Show a => Int -> CallDuration a -> ShowS
forall a. Show a => [CallDuration a] -> ShowS
forall a. Show a => CallDuration a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallDuration a] -> ShowS
$cshowList :: forall a. Show a => [CallDuration a] -> ShowS
show :: CallDuration a -> String
$cshow :: forall a. Show a => CallDuration a -> String
showsPrec :: Int -> CallDuration a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> CallDuration a -> ShowS
Show)
instance Show a => Pretty (CallDuration a) where pretty :: CallDuration a -> Text
pretty = CallDuration a -> Text
forall a. Show a => a -> Text
showt
instance Semigroup (CallDuration a) where
CallDuration a
Unknown <> :: CallDuration a -> CallDuration a -> CallDuration a
<> CallDuration a
a = CallDuration a
a
CallDuration a
a <> CallDuration a
Unknown = CallDuration a
a
CallDuration a
_ <> CallDuration a
a = CallDuration a
a
instance Monoid (CallDuration a) where
mempty :: CallDuration a
mempty = CallDuration a
forall a. CallDuration a
Unknown
mappend :: CallDuration a -> CallDuration a -> CallDuration a
mappend = CallDuration a -> CallDuration a -> CallDuration a
forall a. Semigroup a => a -> a -> a
(<>)
data PatternCall call = PatternCall {
forall call. PatternCall call -> Text
pat_description :: !Text
, forall call. PatternCall call -> DocumentedCall
pat_doc :: !DocumentedCall
, forall call. PatternCall call -> Symbol -> Deriver (Maybe call)
pat_function :: !(Expr.Symbol -> Deriver (Maybe call))
}
pat_call_doc :: PatternCall call -> CallDoc
pat_call_doc :: forall call. PatternCall call -> CallDoc
pat_call_doc PatternCall call
pattern = CallDoc
doc
where DocumentedCall CallName
_ CallDoc
doc = PatternCall call -> DocumentedCall
forall call. PatternCall call -> DocumentedCall
pat_doc PatternCall call
pattern
instance Pretty (PatternCall call) where
pretty :: PatternCall call -> Text
pretty PatternCall call
pattern = Text
"Pattern:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PatternCall call -> Text
forall call. PatternCall call -> Text
pat_description PatternCall call
pattern
data PassedArgs val = PassedArgs {
forall val. PassedArgs val -> [Val]
passed_vals :: ![DeriveT.Val]
, forall val. PassedArgs val -> CallName
passed_call_name :: !CallName
, forall val. PassedArgs val -> Context val
passed_ctx :: !(Context val)
} deriving ((forall a b. (a -> b) -> PassedArgs a -> PassedArgs b)
-> (forall a b. a -> PassedArgs b -> PassedArgs a)
-> Functor PassedArgs
forall a b. a -> PassedArgs b -> PassedArgs a
forall a b. (a -> b) -> PassedArgs a -> PassedArgs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> PassedArgs b -> PassedArgs a
$c<$ :: forall a b. a -> PassedArgs b -> PassedArgs a
fmap :: forall a b. (a -> b) -> PassedArgs a -> PassedArgs b
$cfmap :: forall a b. (a -> b) -> PassedArgs a -> PassedArgs b
Functor)
instance Pretty val => Pretty (PassedArgs val) where
format :: PassedArgs val -> Doc
format (PassedArgs [Val]
vals CallName
call_name Context val
info) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"PassedArgs"
[ (Text
"vals", [Val] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Val]
vals)
, (Text
"call_name", CallName -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CallName
call_name)
, (Text
"info", Context val -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Context val
info)
]
data Context val = Context {
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]
, forall val. Context val -> ScoreTime
ctx_event_end :: !ScoreTime
, forall val. Context val -> ScoreTime
ctx_track_shifted :: !TrackTime
, forall val. Context val -> EventsTree
ctx_sub_tracks :: !TrackTree.EventsTree
, forall val.
Context val -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
ctx_sub_events :: !(Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]])
, forall val. Context val -> Maybe Type
ctx_track_type :: !(Maybe ParseTitle.Type)
} deriving ((forall a b. (a -> b) -> Context a -> Context b)
-> (forall a b. a -> Context b -> Context a) -> Functor Context
forall a b. a -> Context b -> Context a
forall a b. (a -> b) -> Context a -> Context b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Context b -> Context a
$c<$ :: forall a b. a -> Context b -> Context a
fmap :: forall a b. (a -> b) -> Context a -> Context b
$cfmap :: forall a b. (a -> b) -> Context a -> Context b
Functor)
ctx_track_range :: Context a -> (TrackTime, TrackTime)
ctx_track_range :: forall a. Context a -> (ScoreTime, ScoreTime)
ctx_track_range Context a
info = (ScoreTime
shifted, ScoreTime
shifted ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ Context a -> ScoreTime
forall val. Context val -> ScoreTime
ctx_event_end Context a
info)
where shifted :: ScoreTime
shifted = Context a -> ScoreTime
forall val. Context val -> ScoreTime
ctx_track_shifted Context a
info
instance Pretty val => Pretty (Context val) where
format :: Context val -> Doc
format (Context Maybe val
prev_val Event
event [Event]
prev_events [Event]
next_events ScoreTime
event_end
ScoreTime
track_range EventsTree
sub_tracks Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
sub_events Maybe Type
track_type) =
Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Context"
[ (Text
"prev_val", Maybe val -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe val
prev_val)
, (Text
"event", Event -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Event
event)
, (Text
"prev_events", [Event] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Event]
prev_events)
, (Text
"next_events", [Event] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Event]
next_events)
, (Text
"event_end", ScoreTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ScoreTime
event_end)
, (Text
"track_range", ScoreTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ScoreTime
track_range)
, (Text
"sub_tracks", EventsTree -> Doc
forall a. Pretty a => a -> Doc
Pretty.format EventsTree
sub_tracks)
, (Text
"sub_events", Maybe [[(ScoreTime, ScoreTime)]] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Maybe [[(ScoreTime, ScoreTime)]] -> Doc)
-> Maybe [[(ScoreTime, ScoreTime)]] -> Doc
forall a b. (a -> b) -> a -> b
$
([(ScoreTime, ScoreTime, NoteDeriver)] -> [(ScoreTime, ScoreTime)])
-> [[(ScoreTime, ScoreTime, NoteDeriver)]]
-> [[(ScoreTime, ScoreTime)]]
forall a b. (a -> b) -> [a] -> [b]
map (((ScoreTime, ScoreTime, NoteDeriver) -> (ScoreTime, ScoreTime))
-> [(ScoreTime, ScoreTime, NoteDeriver)]
-> [(ScoreTime, ScoreTime)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ScoreTime
s, ScoreTime
d, NoteDeriver
_) -> (ScoreTime
s, ScoreTime
d))) ([[(ScoreTime, ScoreTime, NoteDeriver)]]
-> [[(ScoreTime, ScoreTime)]])
-> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
-> Maybe [[(ScoreTime, ScoreTime)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
sub_events)
, (Text
"track_type", Maybe Type -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe Type
track_type)
]
coerce_context :: Context a -> Context b
coerce_context :: forall a b. Context a -> Context b
coerce_context Context a
ctx = Context a
ctx { ctx_prev_val :: Maybe b
ctx_prev_val = Maybe b
forall a. Maybe a
Nothing }
dummy_context :: ScoreTime -> ScoreTime -> Text -> Context a
dummy_context :: forall a. ScoreTime -> ScoreTime -> Text -> Context a
dummy_context ScoreTime
start ScoreTime
dur Text
text = Context
{ ctx_prev_val :: Maybe a
ctx_prev_val = Maybe a
forall a. Maybe a
Nothing
, ctx_event :: Event
ctx_event = ScoreTime -> ScoreTime -> Text -> Event
Event.event ScoreTime
start ScoreTime
dur Text
text
, ctx_prev_events :: [Event]
ctx_prev_events = []
, ctx_next_events :: [Event]
ctx_next_events = []
, ctx_event_end :: ScoreTime
ctx_event_end = ScoreTime
start ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ ScoreTime
dur
, ctx_track_shifted :: ScoreTime
ctx_track_shifted = ScoreTime
0
, ctx_sub_tracks :: EventsTree
ctx_sub_tracks = []
, ctx_sub_events :: Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
ctx_sub_events = Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
forall a. Maybe a
Nothing
, ctx_track_type :: Maybe Type
ctx_track_type = Maybe Type
forall a. Maybe a
Nothing
}
tag_context :: Taggable a => Context a -> Context Tagged
tag_context :: forall a. Taggable a => Context a -> Context Tagged
tag_context Context a
ctx = Context a
ctx { ctx_prev_val :: Maybe Tagged
ctx_prev_val = a -> Tagged
forall a. Taggable a => a -> Tagged
to_tagged (a -> Tagged) -> Maybe a -> Maybe Tagged
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context a -> Maybe a
forall val. Context val -> Maybe val
ctx_prev_val Context a
ctx }
untag_context :: Taggable a => Context Tagged -> Context a
untag_context :: forall a. Taggable a => Context Tagged -> Context a
untag_context Context Tagged
ctx = Context Tagged
ctx { ctx_prev_val :: Maybe a
ctx_prev_val = Tagged -> Maybe a
forall a. Taggable a => Tagged -> Maybe a
from_tagged (Tagged -> Maybe a) -> Maybe Tagged -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context Tagged -> Maybe Tagged
forall val. Context val -> Maybe val
ctx_prev_val Context Tagged
ctx }
data Call func = Call {
forall func. Call func -> CallName
call_name :: !CallName
, forall func. Call func -> CallDoc
call_doc :: !CallDoc
, forall func. Call func -> func
call_func :: !func
}
type Generator d = Call (GeneratorFunc d)
type Transformer d = Call (TransformerF d)
instance Show (Call d) where
show :: Call d -> String
show Call d
call = String
"((Call " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallName -> String
forall a. Show a => a -> String
show (Call d -> CallName
forall func. Call func -> CallName
call_name Call d
call) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"))"
instance Pretty (Call d) where
pretty :: Call d -> Text
pretty = CallName -> Text
forall a. Pretty a => a -> Text
pretty (CallName -> Text) -> (Call d -> CallName) -> Call d -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Call d -> CallName
forall func. Call func -> CallName
call_name
newtype CallName = CallName Text
deriving (CallName -> CallName -> Bool
(CallName -> CallName -> Bool)
-> (CallName -> CallName -> Bool) -> Eq CallName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallName -> CallName -> Bool
$c/= :: CallName -> CallName -> Bool
== :: CallName -> CallName -> Bool
$c== :: CallName -> CallName -> Bool
Eq, Eq CallName
Eq CallName
-> (CallName -> CallName -> Ordering)
-> (CallName -> CallName -> Bool)
-> (CallName -> CallName -> Bool)
-> (CallName -> CallName -> Bool)
-> (CallName -> CallName -> Bool)
-> (CallName -> CallName -> CallName)
-> (CallName -> CallName -> CallName)
-> Ord CallName
CallName -> CallName -> Bool
CallName -> CallName -> Ordering
CallName -> CallName -> CallName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CallName -> CallName -> CallName
$cmin :: CallName -> CallName -> CallName
max :: CallName -> CallName -> CallName
$cmax :: CallName -> CallName -> CallName
>= :: CallName -> CallName -> Bool
$c>= :: CallName -> CallName -> Bool
> :: CallName -> CallName -> Bool
$c> :: CallName -> CallName -> Bool
<= :: CallName -> CallName -> Bool
$c<= :: CallName -> CallName -> Bool
< :: CallName -> CallName -> Bool
$c< :: CallName -> CallName -> Bool
compare :: CallName -> CallName -> Ordering
$ccompare :: CallName -> CallName -> Ordering
Ord, Int -> CallName -> ShowS
[CallName] -> ShowS
CallName -> String
(Int -> CallName -> ShowS)
-> (CallName -> String) -> ([CallName] -> ShowS) -> Show CallName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallName] -> ShowS
$cshowList :: [CallName] -> ShowS
show :: CallName -> String
$cshow :: CallName -> String
showsPrec :: Int -> CallName -> ShowS
$cshowsPrec :: Int -> CallName -> ShowS
Show, [CallName] -> Doc
CallName -> Text
CallName -> Doc
(CallName -> Text)
-> (CallName -> Doc) -> ([CallName] -> Doc) -> Pretty CallName
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [CallName] -> Doc
$cformatList :: [CallName] -> Doc
format :: CallName -> Doc
$cformat :: CallName -> Doc
pretty :: CallName -> Text
$cpretty :: CallName -> Text
Pretty, String -> CallName
(String -> CallName) -> IsString CallName
forall a. (String -> a) -> IsString a
fromString :: String -> CallName
$cfromString :: String -> CallName
String.IsString)
newtype ArgName = ArgName Text
deriving (ArgName -> ArgName -> Bool
(ArgName -> ArgName -> Bool)
-> (ArgName -> ArgName -> Bool) -> Eq ArgName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgName -> ArgName -> Bool
$c/= :: ArgName -> ArgName -> Bool
== :: ArgName -> ArgName -> Bool
$c== :: ArgName -> ArgName -> Bool
Eq, Eq ArgName
Eq ArgName
-> (ArgName -> ArgName -> Ordering)
-> (ArgName -> ArgName -> Bool)
-> (ArgName -> ArgName -> Bool)
-> (ArgName -> ArgName -> Bool)
-> (ArgName -> ArgName -> Bool)
-> (ArgName -> ArgName -> ArgName)
-> (ArgName -> ArgName -> ArgName)
-> Ord ArgName
ArgName -> ArgName -> Bool
ArgName -> ArgName -> Ordering
ArgName -> ArgName -> ArgName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArgName -> ArgName -> ArgName
$cmin :: ArgName -> ArgName -> ArgName
max :: ArgName -> ArgName -> ArgName
$cmax :: ArgName -> ArgName -> ArgName
>= :: ArgName -> ArgName -> Bool
$c>= :: ArgName -> ArgName -> Bool
> :: ArgName -> ArgName -> Bool
$c> :: ArgName -> ArgName -> Bool
<= :: ArgName -> ArgName -> Bool
$c<= :: ArgName -> ArgName -> Bool
< :: ArgName -> ArgName -> Bool
$c< :: ArgName -> ArgName -> Bool
compare :: ArgName -> ArgName -> Ordering
$ccompare :: ArgName -> ArgName -> Ordering
Ord, Int -> ArgName -> ShowS
[ArgName] -> ShowS
ArgName -> String
(Int -> ArgName -> ShowS)
-> (ArgName -> String) -> ([ArgName] -> ShowS) -> Show ArgName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArgName] -> ShowS
$cshowList :: [ArgName] -> ShowS
show :: ArgName -> String
$cshow :: ArgName -> String
showsPrec :: Int -> ArgName -> ShowS
$cshowsPrec :: Int -> ArgName -> ShowS
Show, [ArgName] -> Doc
ArgName -> Text
ArgName -> Doc
(ArgName -> Text)
-> (ArgName -> Doc) -> ([ArgName] -> Doc) -> Pretty ArgName
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [ArgName] -> Doc
$cformatList :: [ArgName] -> Doc
format :: ArgName -> Doc
$cformat :: ArgName -> Doc
pretty :: ArgName -> Text
$cpretty :: ArgName -> Text
Pretty, String -> ArgName
(String -> ArgName) -> IsString ArgName
forall a. (String -> a) -> IsString a
fromString :: String -> ArgName
$cfromString :: String -> ArgName
String.IsString)
sym_to_call_name :: Expr.Symbol -> CallName
sym_to_call_name :: Symbol -> CallName
sym_to_call_name (Expr.Symbol Text
sym) = Text -> CallName
CallName Text
sym
str_to_call_name :: Expr.Str -> CallName
str_to_call_name :: Str -> CallName
str_to_call_name (Expr.Str Text
str) = Text -> CallName
CallName Text
str
str_to_arg_name :: Expr.Str -> ArgName
str_to_arg_name :: Str -> ArgName
str_to_arg_name (Expr.Str Text
str) = Text -> ArgName
ArgName Text
str
data CallDoc = CallDoc {
CallDoc -> Module
cdoc_module :: !Module.Module
, CallDoc -> Tags
cdoc_tags :: !Tags.Tags
, CallDoc -> Doc
cdoc_doc :: !Doc.Doc
, CallDoc -> [ArgDoc]
cdoc_args :: ![ArgDoc]
} deriving (CallDoc -> CallDoc -> Bool
(CallDoc -> CallDoc -> Bool)
-> (CallDoc -> CallDoc -> Bool) -> Eq CallDoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallDoc -> CallDoc -> Bool
$c/= :: CallDoc -> CallDoc -> Bool
== :: CallDoc -> CallDoc -> Bool
$c== :: CallDoc -> CallDoc -> Bool
Eq, Eq CallDoc
Eq CallDoc
-> (CallDoc -> CallDoc -> Ordering)
-> (CallDoc -> CallDoc -> Bool)
-> (CallDoc -> CallDoc -> Bool)
-> (CallDoc -> CallDoc -> Bool)
-> (CallDoc -> CallDoc -> Bool)
-> (CallDoc -> CallDoc -> CallDoc)
-> (CallDoc -> CallDoc -> CallDoc)
-> Ord CallDoc
CallDoc -> CallDoc -> Bool
CallDoc -> CallDoc -> Ordering
CallDoc -> CallDoc -> CallDoc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CallDoc -> CallDoc -> CallDoc
$cmin :: CallDoc -> CallDoc -> CallDoc
max :: CallDoc -> CallDoc -> CallDoc
$cmax :: CallDoc -> CallDoc -> CallDoc
>= :: CallDoc -> CallDoc -> Bool
$c>= :: CallDoc -> CallDoc -> Bool
> :: CallDoc -> CallDoc -> Bool
$c> :: CallDoc -> CallDoc -> Bool
<= :: CallDoc -> CallDoc -> Bool
$c<= :: CallDoc -> CallDoc -> Bool
< :: CallDoc -> CallDoc -> Bool
$c< :: CallDoc -> CallDoc -> Bool
compare :: CallDoc -> CallDoc -> Ordering
$ccompare :: CallDoc -> CallDoc -> Ordering
Ord, Int -> CallDoc -> ShowS
[CallDoc] -> ShowS
CallDoc -> String
(Int -> CallDoc -> ShowS)
-> (CallDoc -> String) -> ([CallDoc] -> ShowS) -> Show CallDoc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallDoc] -> ShowS
$cshowList :: [CallDoc] -> ShowS
show :: CallDoc -> String
$cshow :: CallDoc -> String
showsPrec :: Int -> CallDoc -> ShowS
$cshowsPrec :: Int -> CallDoc -> ShowS
Show)
data ArgDoc = ArgDoc {
ArgDoc -> ArgName
arg_name :: !ArgName
, ArgDoc -> Type
arg_type :: !ValType.Type
, ArgDoc -> ArgParser
arg_parser :: !ArgParser
, ArgDoc -> EnvironDefault
arg_environ_default :: !EnvironDefault
, ArgDoc -> Doc
arg_doc :: !Doc.Doc
} deriving (ArgDoc -> ArgDoc -> Bool
(ArgDoc -> ArgDoc -> Bool)
-> (ArgDoc -> ArgDoc -> Bool) -> Eq ArgDoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgDoc -> ArgDoc -> Bool
$c/= :: ArgDoc -> ArgDoc -> Bool
== :: ArgDoc -> ArgDoc -> Bool
$c== :: ArgDoc -> ArgDoc -> Bool
Eq, Eq ArgDoc
Eq ArgDoc
-> (ArgDoc -> ArgDoc -> Ordering)
-> (ArgDoc -> ArgDoc -> Bool)
-> (ArgDoc -> ArgDoc -> Bool)
-> (ArgDoc -> ArgDoc -> Bool)
-> (ArgDoc -> ArgDoc -> Bool)
-> (ArgDoc -> ArgDoc -> ArgDoc)
-> (ArgDoc -> ArgDoc -> ArgDoc)
-> Ord ArgDoc
ArgDoc -> ArgDoc -> Bool
ArgDoc -> ArgDoc -> Ordering
ArgDoc -> ArgDoc -> ArgDoc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArgDoc -> ArgDoc -> ArgDoc
$cmin :: ArgDoc -> ArgDoc -> ArgDoc
max :: ArgDoc -> ArgDoc -> ArgDoc
$cmax :: ArgDoc -> ArgDoc -> ArgDoc
>= :: ArgDoc -> ArgDoc -> Bool
$c>= :: ArgDoc -> ArgDoc -> Bool
> :: ArgDoc -> ArgDoc -> Bool
$c> :: ArgDoc -> ArgDoc -> Bool
<= :: ArgDoc -> ArgDoc -> Bool
$c<= :: ArgDoc -> ArgDoc -> Bool
< :: ArgDoc -> ArgDoc -> Bool
$c< :: ArgDoc -> ArgDoc -> Bool
compare :: ArgDoc -> ArgDoc -> Ordering
$ccompare :: ArgDoc -> ArgDoc -> Ordering
Ord, Int -> ArgDoc -> ShowS
[ArgDoc] -> ShowS
ArgDoc -> String
(Int -> ArgDoc -> ShowS)
-> (ArgDoc -> String) -> ([ArgDoc] -> ShowS) -> Show ArgDoc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArgDoc] -> ShowS
$cshowList :: [ArgDoc] -> ShowS
show :: ArgDoc -> String
$cshow :: ArgDoc -> String
showsPrec :: Int -> ArgDoc -> ShowS
$cshowsPrec :: Int -> ArgDoc -> ShowS
Show)
data ArgParser = Required | Defaulted !Text | Optional !Text | Many | Many1
| Environ !(Maybe Text)
deriving (ArgParser -> ArgParser -> Bool
(ArgParser -> ArgParser -> Bool)
-> (ArgParser -> ArgParser -> Bool) -> Eq ArgParser
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgParser -> ArgParser -> Bool
$c/= :: ArgParser -> ArgParser -> Bool
== :: ArgParser -> ArgParser -> Bool
$c== :: ArgParser -> ArgParser -> Bool
Eq, Eq ArgParser
Eq ArgParser
-> (ArgParser -> ArgParser -> Ordering)
-> (ArgParser -> ArgParser -> Bool)
-> (ArgParser -> ArgParser -> Bool)
-> (ArgParser -> ArgParser -> Bool)
-> (ArgParser -> ArgParser -> Bool)
-> (ArgParser -> ArgParser -> ArgParser)
-> (ArgParser -> ArgParser -> ArgParser)
-> Ord ArgParser
ArgParser -> ArgParser -> Bool
ArgParser -> ArgParser -> Ordering
ArgParser -> ArgParser -> ArgParser
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArgParser -> ArgParser -> ArgParser
$cmin :: ArgParser -> ArgParser -> ArgParser
max :: ArgParser -> ArgParser -> ArgParser
$cmax :: ArgParser -> ArgParser -> ArgParser
>= :: ArgParser -> ArgParser -> Bool
$c>= :: ArgParser -> ArgParser -> Bool
> :: ArgParser -> ArgParser -> Bool
$c> :: ArgParser -> ArgParser -> Bool
<= :: ArgParser -> ArgParser -> Bool
$c<= :: ArgParser -> ArgParser -> Bool
< :: ArgParser -> ArgParser -> Bool
$c< :: ArgParser -> ArgParser -> Bool
compare :: ArgParser -> ArgParser -> Ordering
$ccompare :: ArgParser -> ArgParser -> Ordering
Ord, Int -> ArgParser -> ShowS
[ArgParser] -> ShowS
ArgParser -> String
(Int -> ArgParser -> ShowS)
-> (ArgParser -> String)
-> ([ArgParser] -> ShowS)
-> Show ArgParser
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArgParser] -> ShowS
$cshowList :: [ArgParser] -> ShowS
show :: ArgParser -> String
$cshow :: ArgParser -> String
showsPrec :: Int -> ArgParser -> ShowS
$cshowsPrec :: Int -> ArgParser -> ShowS
Show)
data EnvironDefault =
None
| Prefixed
| Unprefixed
| Both
deriving (EnvironDefault -> EnvironDefault -> Bool
(EnvironDefault -> EnvironDefault -> Bool)
-> (EnvironDefault -> EnvironDefault -> Bool) -> Eq EnvironDefault
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EnvironDefault -> EnvironDefault -> Bool
$c/= :: EnvironDefault -> EnvironDefault -> Bool
== :: EnvironDefault -> EnvironDefault -> Bool
$c== :: EnvironDefault -> EnvironDefault -> Bool
Eq, Eq EnvironDefault
Eq EnvironDefault
-> (EnvironDefault -> EnvironDefault -> Ordering)
-> (EnvironDefault -> EnvironDefault -> Bool)
-> (EnvironDefault -> EnvironDefault -> Bool)
-> (EnvironDefault -> EnvironDefault -> Bool)
-> (EnvironDefault -> EnvironDefault -> Bool)
-> (EnvironDefault -> EnvironDefault -> EnvironDefault)
-> (EnvironDefault -> EnvironDefault -> EnvironDefault)
-> Ord EnvironDefault
EnvironDefault -> EnvironDefault -> Bool
EnvironDefault -> EnvironDefault -> Ordering
EnvironDefault -> EnvironDefault -> EnvironDefault
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EnvironDefault -> EnvironDefault -> EnvironDefault
$cmin :: EnvironDefault -> EnvironDefault -> EnvironDefault
max :: EnvironDefault -> EnvironDefault -> EnvironDefault
$cmax :: EnvironDefault -> EnvironDefault -> EnvironDefault
>= :: EnvironDefault -> EnvironDefault -> Bool
$c>= :: EnvironDefault -> EnvironDefault -> Bool
> :: EnvironDefault -> EnvironDefault -> Bool
$c> :: EnvironDefault -> EnvironDefault -> Bool
<= :: EnvironDefault -> EnvironDefault -> Bool
$c<= :: EnvironDefault -> EnvironDefault -> Bool
< :: EnvironDefault -> EnvironDefault -> Bool
$c< :: EnvironDefault -> EnvironDefault -> Bool
compare :: EnvironDefault -> EnvironDefault -> Ordering
$ccompare :: EnvironDefault -> EnvironDefault -> Ordering
Ord, Int -> EnvironDefault -> ShowS
[EnvironDefault] -> ShowS
EnvironDefault -> String
(Int -> EnvironDefault -> ShowS)
-> (EnvironDefault -> String)
-> ([EnvironDefault] -> ShowS)
-> Show EnvironDefault
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EnvironDefault] -> ShowS
$cshowList :: [EnvironDefault] -> ShowS
show :: EnvironDefault -> String
$cshow :: EnvironDefault -> String
showsPrec :: Int -> EnvironDefault -> ShowS
$cshowsPrec :: Int -> EnvironDefault -> ShowS
Show)
type WithArgDoc f = (f, [ArgDoc])
data GeneratorFunc d = GeneratorFunc {
forall d. GeneratorFunc d -> GeneratorF d
gfunc_f :: !(GeneratorF d)
, forall d.
GeneratorFunc d -> PassedArgs d -> Deriver (CallDuration ScoreTime)
gfunc_score_duration
:: !(PassedArgs d -> Deriver (CallDuration ScoreTime))
, forall d.
GeneratorFunc d -> PassedArgs d -> Deriver (CallDuration RealTime)
gfunc_real_duration :: !(PassedArgs d -> Deriver (CallDuration RealTime))
}
type GeneratorF d = PassedArgs d -> Deriver (Stream.Stream d)
generator_func :: (PassedArgs d -> Deriver (Stream.Stream d)) -> GeneratorFunc d
generator_func :: forall d. (PassedArgs d -> Deriver (Stream d)) -> GeneratorFunc d
generator_func PassedArgs d -> Deriver (Stream d)
f = GeneratorFunc
{ gfunc_f :: PassedArgs d -> Deriver (Stream d)
gfunc_f = PassedArgs d -> Deriver (Stream d)
f
, gfunc_score_duration :: PassedArgs d -> Deriver (CallDuration ScoreTime)
gfunc_score_duration = PassedArgs d -> Deriver (CallDuration ScoreTime)
forall d. PassedArgs d -> Deriver (CallDuration ScoreTime)
default_score_duration
, gfunc_real_duration :: PassedArgs d -> Deriver (CallDuration RealTime)
gfunc_real_duration = PassedArgs d -> Deriver (CallDuration RealTime)
forall d. PassedArgs d -> Deriver (CallDuration RealTime)
default_real_duration
}
default_score_duration :: PassedArgs d -> Deriver (CallDuration ScoreTime)
default_score_duration :: forall d. PassedArgs d -> Deriver (CallDuration ScoreTime)
default_score_duration =
CallDuration ScoreTime -> Deriver (CallDuration ScoreTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (CallDuration ScoreTime -> Deriver (CallDuration ScoreTime))
-> (PassedArgs d -> CallDuration ScoreTime)
-> PassedArgs d
-> Deriver (CallDuration ScoreTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> CallDuration ScoreTime
forall a. a -> CallDuration a
CallDuration (ScoreTime -> CallDuration ScoreTime)
-> (PassedArgs d -> ScoreTime)
-> PassedArgs d
-> CallDuration ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> ScoreTime
Event.duration (Event -> ScoreTime)
-> (PassedArgs d -> Event) -> PassedArgs d -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context d -> Event
forall val. Context val -> Event
ctx_event (Context d -> Event)
-> (PassedArgs d -> Context d) -> PassedArgs d -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs d -> Context d
forall val. PassedArgs val -> Context val
passed_ctx
default_real_duration :: PassedArgs d -> Deriver (CallDuration RealTime)
default_real_duration :: forall d. PassedArgs d -> Deriver (CallDuration RealTime)
default_real_duration PassedArgs d
args = RealTime -> CallDuration RealTime
forall a. a -> CallDuration a
CallDuration (RealTime -> CallDuration RealTime)
-> Deriver State Error RealTime -> Deriver (CallDuration RealTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
ScoreTime -> Deriver State Error RealTime
score_to_real (Event -> ScoreTime
Event.duration (Event -> ScoreTime) -> Event -> ScoreTime
forall a b. (a -> b) -> a -> b
$ Context d -> Event
forall val. Context val -> Event
ctx_event (Context d -> Event) -> Context d -> Event
forall a b. (a -> b) -> a -> b
$ PassedArgs d -> Context d
forall val. PassedArgs val -> Context val
passed_ctx PassedArgs d
args)
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
}
generator :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
-> WithArgDoc (GeneratorF d) -> Generator d
generator :: forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
generator Module
module_ CallName
name Tags
tags Doc
doc (GeneratorF d
func, [ArgDoc]
arg_docs) =
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorFunc d)
-> Call (GeneratorFunc d)
forall func.
Module -> CallName -> Tags -> Doc -> WithArgDoc func -> Call func
make_call Module
module_ CallName
name Tags
tags Doc
doc (GeneratorF d -> GeneratorFunc d
forall d. (PassedArgs d -> Deriver (Stream d)) -> GeneratorFunc d
generator_func GeneratorF d
func, [ArgDoc]
arg_docs)
generator_events :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
-> WithArgDoc (PassedArgs d -> Deriver [d]) -> Generator d
generator_events :: forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver [d])
-> Generator d
generator_events Module
module_ CallName
name Tags
tags Doc
doc (PassedArgs d -> Deriver [d]
func, [ArgDoc]
arg_docs) =
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
generator Module
module_ CallName
name Tags
tags Doc
doc
(([d] -> Stream d
forall a. [a] -> Stream a
Stream.from_sorted_events <$>) (Deriver [d] -> Deriver (Stream d))
-> (PassedArgs d -> Deriver [d]) -> GeneratorF d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs d -> Deriver [d]
func, [ArgDoc]
arg_docs)
generator1 :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
-> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d
generator1 :: forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
generator1 Module
module_ CallName
name Tags
tags Doc
doc (PassedArgs d -> Deriver d
func, [ArgDoc]
arg_docs) =
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
generator Module
module_ CallName
name Tags
tags Doc
doc
((d -> Stream d
forall a. a -> Stream a
Stream.from_event <$>) (Deriver d -> Deriver (Stream d))
-> (PassedArgs d -> Deriver d) -> GeneratorF d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs d -> Deriver d
func, [ArgDoc]
arg_docs)
with_score_duration :: (PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
with_score_duration :: forall d.
(PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
with_score_duration PassedArgs d -> Deriver (CallDuration ScoreTime)
get Generator d
call = Generator d
call
{ call_func :: GeneratorFunc d
call_func = (Generator d -> GeneratorFunc d
forall func. Call func -> func
call_func Generator d
call) { gfunc_score_duration :: PassedArgs d -> Deriver (CallDuration ScoreTime)
gfunc_score_duration = PassedArgs d -> Deriver (CallDuration ScoreTime)
get } }
with_real_duration :: (PassedArgs d -> Deriver (CallDuration RealTime))
-> Generator d -> Generator d
with_real_duration :: forall d.
(PassedArgs d -> Deriver (CallDuration RealTime))
-> Generator d -> Generator d
with_real_duration PassedArgs d -> Deriver (CallDuration RealTime)
get Generator d
call = Generator d
call
{ call_func :: GeneratorFunc d
call_func = (Generator d -> GeneratorFunc d
forall func. Call func -> func
call_func Generator d
call) { gfunc_real_duration :: PassedArgs d -> Deriver (CallDuration RealTime)
gfunc_real_duration = PassedArgs d -> Deriver (CallDuration RealTime)
get } }
transformer :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
-> WithArgDoc (TransformerF d) -> Transformer d
transformer :: forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
transformer = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Call (TransformerF d)
forall func.
Module -> CallName -> Tags -> Doc -> WithArgDoc func -> Call func
make_call
data ValCall = ValCall {
ValCall -> CallName
vcall_name :: !CallName
, ValCall -> CallDoc
vcall_doc :: !CallDoc
, ValCall -> PassedArgs Tagged -> Deriver Val
vcall_call :: PassedArgs Tagged -> Deriver DeriveT.Val
}
instance Show ValCall where
show :: ValCall -> String
show (ValCall CallName
name CallDoc
_ PassedArgs Tagged -> Deriver Val
_) = String
"((ValCall " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallName -> String
forall a. Show a => a -> String
show CallName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"))"
make_val_call :: Module.Module -> CallName -> Tags.Tags -> Doc.Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver DeriveT.Val) -> ValCall
make_val_call :: Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
make_val_call Module
module_ CallName
name Tags
tags Doc
doc (PassedArgs Tagged -> Deriver Val
call, [ArgDoc]
arg_docs) = ValCall
{ vcall_name :: CallName
vcall_name = CallName
name
, vcall_doc :: CallDoc
vcall_doc = CallDoc
{ cdoc_module :: Module
cdoc_module = Module
module_
, cdoc_tags :: Tags
cdoc_tags = Tags
tags
, cdoc_doc :: Doc
cdoc_doc = Doc
doc
, cdoc_args :: [ArgDoc]
cdoc_args = [ArgDoc]
arg_docs
}
, vcall_call :: PassedArgs Tagged -> Deriver Val
vcall_call = PassedArgs Tagged -> Deriver Val
call
}
newtype Cache = Cache (Map CacheKey Cached)
deriving (NonEmpty Cache -> Cache
Cache -> Cache -> Cache
(Cache -> Cache -> Cache)
-> (NonEmpty Cache -> Cache)
-> (forall b. Integral b => b -> Cache -> Cache)
-> Semigroup Cache
forall b. Integral b => b -> Cache -> Cache
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Cache -> Cache
$cstimes :: forall b. Integral b => b -> Cache -> Cache
sconcat :: NonEmpty Cache -> Cache
$csconcat :: NonEmpty Cache -> Cache
<> :: Cache -> Cache -> Cache
$c<> :: Cache -> Cache -> Cache
Semigroup, Semigroup Cache
Cache
Semigroup Cache
-> Cache
-> (Cache -> Cache -> Cache)
-> ([Cache] -> Cache)
-> Monoid Cache
[Cache] -> Cache
Cache -> Cache -> Cache
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Cache] -> Cache
$cmconcat :: [Cache] -> Cache
mappend :: Cache -> Cache -> Cache
$cmappend :: Cache -> Cache -> Cache
mempty :: Cache
$cmempty :: Cache
Monoid, [Cache] -> Doc
Cache -> Text
Cache -> Doc
(Cache -> Text)
-> (Cache -> Doc) -> ([Cache] -> Doc) -> Pretty Cache
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [Cache] -> Doc
$cformatList :: [Cache] -> Doc
format :: Cache -> Doc
$cformat :: Cache -> Doc
pretty :: Cache -> Text
$cpretty :: Cache -> Text
Pretty, Cache -> ()
(Cache -> ()) -> NFData Cache
forall a. (a -> ()) -> NFData a
rnf :: Cache -> ()
$crnf :: Cache -> ()
DeepSeq.NFData)
cache_size :: Cache -> Int
cache_size :: Cache -> Int
cache_size (Cache Map CacheKey Cached
c) = Map CacheKey Cached -> Int
forall k a. Map k a -> Int
Map.size Map CacheKey Cached
c
newtype CacheKey = CacheKey { CacheKey -> Stack
key_stack :: Stack.Stack }
deriving (CacheKey -> CacheKey -> Bool
(CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool) -> Eq CacheKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheKey -> CacheKey -> Bool
$c/= :: CacheKey -> CacheKey -> Bool
== :: CacheKey -> CacheKey -> Bool
$c== :: CacheKey -> CacheKey -> Bool
Eq, Eq CacheKey
Eq CacheKey
-> (CacheKey -> CacheKey -> Ordering)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> CacheKey)
-> (CacheKey -> CacheKey -> CacheKey)
-> Ord CacheKey
CacheKey -> CacheKey -> Bool
CacheKey -> CacheKey -> Ordering
CacheKey -> CacheKey -> CacheKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CacheKey -> CacheKey -> CacheKey
$cmin :: CacheKey -> CacheKey -> CacheKey
max :: CacheKey -> CacheKey -> CacheKey
$cmax :: CacheKey -> CacheKey -> CacheKey
>= :: CacheKey -> CacheKey -> Bool
$c>= :: CacheKey -> CacheKey -> Bool
> :: CacheKey -> CacheKey -> Bool
$c> :: CacheKey -> CacheKey -> Bool
<= :: CacheKey -> CacheKey -> Bool
$c<= :: CacheKey -> CacheKey -> Bool
< :: CacheKey -> CacheKey -> Bool
$c< :: CacheKey -> CacheKey -> Bool
compare :: CacheKey -> CacheKey -> Ordering
$ccompare :: CacheKey -> CacheKey -> Ordering
Ord, Int -> CacheKey -> ShowS
[CacheKey] -> ShowS
CacheKey -> String
(Int -> CacheKey -> ShowS)
-> (CacheKey -> String) -> ([CacheKey] -> ShowS) -> Show CacheKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheKey] -> ShowS
$cshowList :: [CacheKey] -> ShowS
show :: CacheKey -> String
$cshow :: CacheKey -> String
showsPrec :: Int -> CacheKey -> ShowS
$cshowsPrec :: Int -> CacheKey -> ShowS
Show, CacheKey -> ()
(CacheKey -> ()) -> NFData CacheKey
forall a. (a -> ()) -> NFData a
rnf :: CacheKey -> ()
$crnf :: CacheKey -> ()
DeepSeq.NFData, [CacheKey] -> Doc
CacheKey -> Text
CacheKey -> Doc
(CacheKey -> Text)
-> (CacheKey -> Doc) -> ([CacheKey] -> Doc) -> Pretty CacheKey
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [CacheKey] -> Doc
$cformatList :: [CacheKey] -> Doc
format :: CacheKey -> Doc
$cformat :: CacheKey -> Doc
pretty :: CacheKey -> Text
$cpretty :: CacheKey -> Text
Pretty)
data Cached = Cached !CacheEntry | Invalid
instance Pretty Cached where
format :: Cached -> Doc
format Cached
Invalid = Text -> Doc
Pretty.text Text
"Invalid"
format (Cached CacheEntry
entry) = CacheEntry -> Doc
forall a. Pretty a => a -> Doc
Pretty.format CacheEntry
entry
instance DeepSeq.NFData Cached where
rnf :: Cached -> ()
rnf Cached
Invalid = ()
rnf (Cached CacheEntry
entry) = CacheEntry -> ()
forall a. NFData a => a -> ()
rnf CacheEntry
entry
data CacheEntry =
CachedEvents !(CallType Score.Event)
| CachedControl !(CallType Signal.Control)
| CachedPitch !(CallType PSignal.PSignal)
instance Pretty CacheEntry where
format :: CacheEntry -> Doc
format (CachedEvents (CallType Collect
_ Stream Event
events)) = Stream Event -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stream Event
events
format (CachedControl (CallType Collect
_ Stream Control
events)) = Stream Control -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stream Control
events
format (CachedPitch (CallType Collect
_ Stream PSignal
events)) = Stream PSignal -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stream PSignal
events
instance DeepSeq.NFData CacheEntry where
rnf :: CacheEntry -> ()
rnf (CachedEvents CallType Event
c) = CallType Event -> ()
forall a. NFData a => a -> ()
rnf CallType Event
c
rnf (CachedControl CallType Control
c) = CallType Control -> ()
forall a. NFData a => a -> ()
rnf CallType Control
c
rnf (CachedPitch CallType PSignal
c) = CallType PSignal -> ()
forall a. NFData a => a -> ()
rnf CallType PSignal
c
data CallType d = CallType !Collect !(Stream.Stream d)
instance DeepSeq.NFData d => DeepSeq.NFData (CallType d) where
rnf :: CallType d -> ()
rnf (CallType Collect
collect Stream d
events) = Collect -> ()
forall a. NFData a => a -> ()
rnf Collect
collect () -> () -> ()
`seq` Stream d -> ()
forall a. NFData a => a -> ()
rnf Stream d
events
newtype BlockDeps = BlockDeps (Set BlockId)
deriving ([BlockDeps] -> Doc
BlockDeps -> Text
BlockDeps -> Doc
(BlockDeps -> Text)
-> (BlockDeps -> Doc) -> ([BlockDeps] -> Doc) -> Pretty BlockDeps
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [BlockDeps] -> Doc
$cformatList :: [BlockDeps] -> Doc
format :: BlockDeps -> Doc
$cformat :: BlockDeps -> Doc
pretty :: BlockDeps -> Text
$cpretty :: BlockDeps -> Text
Pretty, NonEmpty BlockDeps -> BlockDeps
BlockDeps -> BlockDeps -> BlockDeps
(BlockDeps -> BlockDeps -> BlockDeps)
-> (NonEmpty BlockDeps -> BlockDeps)
-> (forall b. Integral b => b -> BlockDeps -> BlockDeps)
-> Semigroup BlockDeps
forall b. Integral b => b -> BlockDeps -> BlockDeps
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> BlockDeps -> BlockDeps
$cstimes :: forall b. Integral b => b -> BlockDeps -> BlockDeps
sconcat :: NonEmpty BlockDeps -> BlockDeps
$csconcat :: NonEmpty BlockDeps -> BlockDeps
<> :: BlockDeps -> BlockDeps -> BlockDeps
$c<> :: BlockDeps -> BlockDeps -> BlockDeps
Semigroup, Semigroup BlockDeps
BlockDeps
Semigroup BlockDeps
-> BlockDeps
-> (BlockDeps -> BlockDeps -> BlockDeps)
-> ([BlockDeps] -> BlockDeps)
-> Monoid BlockDeps
[BlockDeps] -> BlockDeps
BlockDeps -> BlockDeps -> BlockDeps
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [BlockDeps] -> BlockDeps
$cmconcat :: [BlockDeps] -> BlockDeps
mappend :: BlockDeps -> BlockDeps -> BlockDeps
$cmappend :: BlockDeps -> BlockDeps -> BlockDeps
mempty :: BlockDeps
$cmempty :: BlockDeps
Monoid, Int -> BlockDeps -> ShowS
[BlockDeps] -> ShowS
BlockDeps -> String
(Int -> BlockDeps -> ShowS)
-> (BlockDeps -> String)
-> ([BlockDeps] -> ShowS)
-> Show BlockDeps
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockDeps] -> ShowS
$cshowList :: [BlockDeps] -> ShowS
show :: BlockDeps -> String
$cshow :: BlockDeps -> String
showsPrec :: Int -> BlockDeps -> ShowS
$cshowsPrec :: Int -> BlockDeps -> ShowS
Show, BlockDeps -> BlockDeps -> Bool
(BlockDeps -> BlockDeps -> Bool)
-> (BlockDeps -> BlockDeps -> Bool) -> Eq BlockDeps
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockDeps -> BlockDeps -> Bool
$c/= :: BlockDeps -> BlockDeps -> Bool
== :: BlockDeps -> BlockDeps -> Bool
$c== :: BlockDeps -> BlockDeps -> Bool
Eq, BlockDeps -> ()
(BlockDeps -> ()) -> NFData BlockDeps
forall a. (a -> ()) -> NFData a
rnf :: BlockDeps -> ()
$crnf :: BlockDeps -> ()
DeepSeq.NFData)
data ScoreDamage = ScoreDamage {
ScoreDamage -> Map TrackId (Ranges ScoreTime)
sdamage_tracks :: !(Map TrackId (Ranges.Ranges ScoreTime))
, ScoreDamage -> Set BlockId
sdamage_track_blocks :: !(Set BlockId)
, ScoreDamage -> Set BlockId
sdamage_blocks :: !(Set BlockId)
} deriving (ScoreDamage -> ScoreDamage -> Bool
(ScoreDamage -> ScoreDamage -> Bool)
-> (ScoreDamage -> ScoreDamage -> Bool) -> Eq ScoreDamage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScoreDamage -> ScoreDamage -> Bool
$c/= :: ScoreDamage -> ScoreDamage -> Bool
== :: ScoreDamage -> ScoreDamage -> Bool
$c== :: ScoreDamage -> ScoreDamage -> Bool
Eq, Int -> ScoreDamage -> ShowS
[ScoreDamage] -> ShowS
ScoreDamage -> String
(Int -> ScoreDamage -> ShowS)
-> (ScoreDamage -> String)
-> ([ScoreDamage] -> ShowS)
-> Show ScoreDamage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScoreDamage] -> ShowS
$cshowList :: [ScoreDamage] -> ShowS
show :: ScoreDamage -> String
$cshow :: ScoreDamage -> String
showsPrec :: Int -> ScoreDamage -> ShowS
$cshowsPrec :: Int -> ScoreDamage -> ShowS
Show)
instance Semigroup ScoreDamage where
<> :: ScoreDamage -> ScoreDamage -> ScoreDamage
(<>) (ScoreDamage Map TrackId (Ranges ScoreTime)
tracks1 Set BlockId
tblocks1 Set BlockId
blocks1)
(ScoreDamage Map TrackId (Ranges ScoreTime)
tracks2 Set BlockId
tblocks2 Set BlockId
blocks2) =
Map TrackId (Ranges ScoreTime)
-> Set BlockId -> Set BlockId -> ScoreDamage
ScoreDamage (Map TrackId (Ranges ScoreTime)
-> Map TrackId (Ranges ScoreTime) -> Map TrackId (Ranges ScoreTime)
forall k a. (Ord k, Monoid a) => Map k a -> Map k a -> Map k a
Maps.mappend Map TrackId (Ranges ScoreTime)
tracks1 Map TrackId (Ranges ScoreTime)
tracks2)
(Set BlockId
tblocks1 Set BlockId -> Set BlockId -> Set BlockId
forall a. Semigroup a => a -> a -> a
<> Set BlockId
tblocks2) (Set BlockId
blocks1 Set BlockId -> Set BlockId -> Set BlockId
forall a. Semigroup a => a -> a -> a
<> Set BlockId
blocks2)
instance Monoid ScoreDamage where
mempty :: ScoreDamage
mempty = Map TrackId (Ranges ScoreTime)
-> Set BlockId -> Set BlockId -> ScoreDamage
ScoreDamage Map TrackId (Ranges ScoreTime)
forall k a. Map k a
Map.empty Set BlockId
forall a. Set a
Set.empty Set BlockId
forall a. Set a
Set.empty
mappend :: ScoreDamage -> ScoreDamage -> ScoreDamage
mappend = ScoreDamage -> ScoreDamage -> ScoreDamage
forall a. Semigroup a => a -> a -> a
(<>)
instance Pretty ScoreDamage where
format :: ScoreDamage -> Doc
format (ScoreDamage Map TrackId (Ranges ScoreTime)
tracks Set BlockId
track_blocks Set BlockId
blocks) =
Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"ScoreDamage"
[ (Text
"tracks", Map TrackId (Ranges ScoreTime) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map TrackId (Ranges ScoreTime)
tracks)
, (Text
"track_blocks", Set BlockId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Set BlockId
track_blocks)
, (Text
"blocks", Set BlockId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Set BlockId
blocks)
]
instance DeepSeq.NFData ScoreDamage where
rnf :: ScoreDamage -> ()
rnf (ScoreDamage Map TrackId (Ranges ScoreTime)
tracks Set BlockId
track_blocks Set BlockId
blocks) =
Map TrackId (Ranges ScoreTime) -> ()
forall a. NFData a => a -> ()
rnf Map TrackId (Ranges ScoreTime)
tracks () -> () -> ()
`seq` Set BlockId -> ()
forall a. NFData a => a -> ()
rnf Set BlockId
track_blocks () -> () -> ()
`seq` Set BlockId -> ()
forall a. NFData a => a -> ()
rnf Set BlockId
blocks
invalidate_damaged :: ScoreDamage -> Cache -> Cache
invalidate_damaged :: ScoreDamage -> Cache -> Cache
invalidate_damaged (ScoreDamage Map TrackId (Ranges ScoreTime)
tracks Set BlockId
_ Set BlockId
blocks) (Cache Map CacheKey Cached
cache) =
Map CacheKey Cached -> Cache
Cache (Map CacheKey Cached -> Cache) -> Map CacheKey Cached -> Cache
forall a b. (a -> b) -> a -> b
$ (CacheKey -> Cached -> Cached)
-> Map CacheKey Cached -> Map CacheKey Cached
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey CacheKey -> Cached -> Cached
invalidate (Map CacheKey Cached -> Map CacheKey Cached)
-> Map CacheKey Cached -> Map CacheKey Cached
forall a b. (a -> b) -> a -> b
$ (Cached -> Bool) -> Map CacheKey Cached -> Map CacheKey Cached
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Cached -> Bool
is_valid Map CacheKey Cached
cache
where
is_valid :: Cached -> Bool
is_valid Cached
Invalid = Bool
False
is_valid Cached
_ = Bool
True
invalidate :: CacheKey -> Cached -> Cached
invalidate CacheKey
key Cached
cached
| Stack -> Bool
has_damage (CacheKey -> Stack
key_stack CacheKey
key) = Cached
Invalid
| Bool
otherwise = Cached
cached
has_damage :: Stack -> Bool
has_damage Stack
stack = ((Maybe BlockId, Maybe TrackId, Maybe (ScoreTime, ScoreTime))
-> Bool)
-> [(Maybe BlockId, Maybe TrackId, Maybe (ScoreTime, ScoreTime))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe BlockId, Maybe TrackId, Maybe (ScoreTime, ScoreTime))
-> Bool
overlaps (Stack
-> [(Maybe BlockId, Maybe TrackId, Maybe (ScoreTime, ScoreTime))]
Stack.to_ui_innermost Stack
stack)
overlaps :: (Maybe BlockId, Maybe TrackId, Maybe (ScoreTime, ScoreTime))
-> Bool
overlaps (Maybe BlockId
block, Maybe TrackId
track, Maybe (ScoreTime, ScoreTime)
range) = Bool -> (BlockId -> Bool) -> Maybe BlockId -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (BlockId -> Set BlockId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BlockId
blocks) Maybe BlockId
block
Bool -> Bool -> Bool
|| case (Maybe TrackId
track, Maybe (ScoreTime, ScoreTime)
range) of
(Just TrackId
track_id, Maybe (ScoreTime, ScoreTime)
Nothing) -> TrackId -> Map TrackId (Ranges ScoreTime) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TrackId
track_id Map TrackId (Ranges ScoreTime)
tracks
(Just TrackId
track_id, Just (ScoreTime
s, ScoreTime
e))
| Just Ranges ScoreTime
ranges <- TrackId
-> Map TrackId (Ranges ScoreTime) -> Maybe (Ranges ScoreTime)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
track_id Map TrackId (Ranges ScoreTime)
tracks ->
Ranges ScoreTime -> Ranges ScoreTime -> Bool
forall n. Ord n => Ranges n -> Ranges n -> Bool
Ranges.overlapping Ranges ScoreTime
ranges (ScoreTime -> ScoreTime -> Ranges ScoreTime
forall n. n -> n -> Ranges n
Ranges.range ScoreTime
s ScoreTime
e)
(Maybe TrackId, Maybe (ScoreTime, ScoreTime))
_ -> Bool
False
newtype ControlDamage = ControlDamage (Ranges.Ranges ScoreTime)
deriving ([ControlDamage] -> Doc
ControlDamage -> Text
ControlDamage -> Doc
(ControlDamage -> Text)
-> (ControlDamage -> Doc)
-> ([ControlDamage] -> Doc)
-> Pretty ControlDamage
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [ControlDamage] -> Doc
$cformatList :: [ControlDamage] -> Doc
format :: ControlDamage -> Doc
$cformat :: ControlDamage -> Doc
pretty :: ControlDamage -> Text
$cpretty :: ControlDamage -> Text
Pretty, NonEmpty ControlDamage -> ControlDamage
ControlDamage -> ControlDamage -> ControlDamage
(ControlDamage -> ControlDamage -> ControlDamage)
-> (NonEmpty ControlDamage -> ControlDamage)
-> (forall b. Integral b => b -> ControlDamage -> ControlDamage)
-> Semigroup ControlDamage
forall b. Integral b => b -> ControlDamage -> ControlDamage
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> ControlDamage -> ControlDamage
$cstimes :: forall b. Integral b => b -> ControlDamage -> ControlDamage
sconcat :: NonEmpty ControlDamage -> ControlDamage
$csconcat :: NonEmpty ControlDamage -> ControlDamage
<> :: ControlDamage -> ControlDamage -> ControlDamage
$c<> :: ControlDamage -> ControlDamage -> ControlDamage
Semigroup, Semigroup ControlDamage
ControlDamage
Semigroup ControlDamage
-> ControlDamage
-> (ControlDamage -> ControlDamage -> ControlDamage)
-> ([ControlDamage] -> ControlDamage)
-> Monoid ControlDamage
[ControlDamage] -> ControlDamage
ControlDamage -> ControlDamage -> ControlDamage
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ControlDamage] -> ControlDamage
$cmconcat :: [ControlDamage] -> ControlDamage
mappend :: ControlDamage -> ControlDamage -> ControlDamage
$cmappend :: ControlDamage -> ControlDamage -> ControlDamage
mempty :: ControlDamage
$cmempty :: ControlDamage
Monoid, ControlDamage -> ControlDamage -> Bool
(ControlDamage -> ControlDamage -> Bool)
-> (ControlDamage -> ControlDamage -> Bool) -> Eq ControlDamage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ControlDamage -> ControlDamage -> Bool
$c/= :: ControlDamage -> ControlDamage -> Bool
== :: ControlDamage -> ControlDamage -> Bool
$c== :: ControlDamage -> ControlDamage -> Bool
Eq, Int -> ControlDamage -> ShowS
[ControlDamage] -> ShowS
ControlDamage -> String
(Int -> ControlDamage -> ShowS)
-> (ControlDamage -> String)
-> ([ControlDamage] -> ShowS)
-> Show ControlDamage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlDamage] -> ShowS
$cshowList :: [ControlDamage] -> ShowS
show :: ControlDamage -> String
$cshow :: ControlDamage -> String
showsPrec :: Int -> ControlDamage -> ShowS
$cshowsPrec :: Int -> ControlDamage -> ShowS
Show, ControlDamage -> ()
(ControlDamage -> ()) -> NFData ControlDamage
forall a. (a -> ()) -> NFData a
rnf :: ControlDamage -> ()
$crnf :: ControlDamage -> ()
DeepSeq.NFData)
{-# SCC score_to_real #-}
score_to_real :: ScoreTime -> Deriver RealTime
score_to_real :: ScoreTime -> Deriver State Error RealTime
score_to_real ScoreTime
pos = do
Warp
warp <- (State -> Warp) -> Deriver State Error Warp
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Warp
state_warp (Dynamic -> Warp) -> (State -> Dynamic) -> State -> Warp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
RealTime -> Deriver State Error RealTime
forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime -> Deriver State Error RealTime)
-> RealTime -> Deriver State Error RealTime
forall a b. (a -> b) -> a -> b
$ Warp -> ScoreTime -> RealTime
Warp.warp Warp
warp ScoreTime
pos
{-# SCC real_to_score #-}
real_to_score :: RealTime -> Deriver ScoreTime
real_to_score :: RealTime -> Deriver ScoreTime
real_to_score RealTime
pos = do
Warp
warp <- (State -> Warp) -> Deriver State Error Warp
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> Warp
state_warp (Dynamic -> Warp) -> (State -> Dynamic) -> State -> Warp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)
ScoreTime -> Deriver ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ScoreTime -> Deriver ScoreTime) -> ScoreTime -> Deriver ScoreTime
forall a b. (a -> b) -> a -> b
$ Warp -> RealTime -> ScoreTime
Warp.unwarp Warp
warp RealTime
pos
data Scale = Scale {
Scale -> ScaleId
scale_id :: !Pitch.ScaleId
, Scale -> Text
scale_pattern :: !Text
, Scale -> [Symbol]
scale_symbols :: ![Symbol.Symbol]
, Scale -> Set Control
scale_transposers :: !(Set ScoreT.Control)
, 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
, Scale -> Pitch
scale_bottom :: !Pitch.Pitch
, Scale -> Layout
scale_layout :: !Layout
, Scale -> Transpose
scale_transpose :: !Transpose
, Scale -> Enharmonics
scale_enharmonics :: !Enharmonics
, Scale -> Note -> Maybe ValCall
scale_note_to_call :: !(Pitch.Note -> Maybe ValCall)
, Scale -> Environ -> Input -> Either PitchError Note
scale_input_to_note :: !(DeriveT.Environ -> Pitch.Input
-> Either DeriveT.PitchError Pitch.Note)
, Scale
-> ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
scale_input_to_nn :: !(ScoreTime -> Pitch.Input
-> Deriver (Either DeriveT.PitchError Pitch.NoteNumber))
, Scale -> DocumentedCall
scale_call_doc :: !DocumentedCall
}
instance Pretty Scale where
pretty :: Scale -> Text
pretty = ScaleId -> Text
forall a. Pretty a => a -> Text
pretty (ScaleId -> Text) -> (Scale -> ScaleId) -> Scale -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> ScaleId
scale_id
newtype LookupScale = LookupScale (DeriveT.Environ
-> Pitch.ScaleId -> Maybe (Either DeriveT.PitchError Scale))
instance Show LookupScale where show :: LookupScale -> String
show LookupScale
_ = String
"((LookupScale))"
type Transpose = Transposition -> DeriveT.Environ -> Pitch.Step -> Pitch.Pitch
-> Either DeriveT.PitchError Pitch.Pitch
data Transposition = Chromatic | Diatonic deriving (Int -> Transposition -> ShowS
[Transposition] -> ShowS
Transposition -> String
(Int -> Transposition -> ShowS)
-> (Transposition -> String)
-> ([Transposition] -> ShowS)
-> Show Transposition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Transposition] -> ShowS
$cshowList :: [Transposition] -> ShowS
show :: Transposition -> String
$cshow :: Transposition -> String
showsPrec :: Int -> Transposition -> ShowS
$cshowsPrec :: Int -> Transposition -> ShowS
Show)
type Enharmonics = DeriveT.Environ -> Pitch.Note
-> Either DeriveT.PitchError [Pitch.Note]
type Layout = Vector.Unboxed.Vector Pitch.Semi
d_merge :: [NoteDeriver] -> NoteDeriver
d_merge :: [NoteDeriver] -> NoteDeriver
d_merge [] = NoteDeriver
forall a. Monoid a => a
mempty
d_merge [NoteDeriver
d] = NoteDeriver
d
d_merge [NoteDeriver]
derivers = [Stream Event] -> Stream Event
forall a. Monoid a => [a] -> a
mconcat ([Stream Event] -> Stream Event)
-> Deriver State Error [Stream Event] -> NoteDeriver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NoteDeriver] -> Deriver State Error [Stream Event]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [NoteDeriver]
derivers
merge_logs :: Either Error (Stream.Stream a) -> [Log.Msg] -> Stream.Stream a
merge_logs :: forall a. Either Error (Stream a) -> [Msg] -> Stream a
merge_logs Either Error (Stream a)
result [Msg]
logs = case Either Error (Stream a)
result of
Right Stream a
stream -> [Msg] -> Stream a -> Stream a
forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs [Msg]
logs Stream a
stream
Left Error
err -> [Msg] -> Stream a
forall a. [Msg] -> Stream a
Stream.from_logs ([Msg] -> Stream a) -> [Msg] -> Stream a
forall a b. (a -> b) -> a -> b
$ Error -> Msg
error_to_warn Error
err Msg -> [Msg] -> [Msg]
forall a. a -> [a] -> [a]
: [Msg]
logs
error_to_warn :: Error -> Log.Msg
error_to_warn :: Error -> Msg
error_to_warn (Error CallStack
call_stack Stack
stack ErrorVal
error_val) =
CallStack -> Priority -> Maybe Stack -> Text -> Msg
Log.msg_call_stack CallStack
call_stack Priority
Log.Warn (Stack -> Maybe Stack
forall a. a -> Maybe a
Just Stack
stack) (ErrorVal -> Text
forall a. Pretty a => a -> Text
pretty ErrorVal
error_val)