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

-- | Functions for instrument cmds.  This is called DUtil because there is also
-- "Cmd.Instrument.CUtil" and they are usually imported together.
--
-- I need a better name than \"Util\" for everything.
module Derive.Instrument.DUtil where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Util.Log as Log
import qualified Cmd.Cmd as Cmd
import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.C.Prelude.Note as Note
import qualified Derive.Call as Call
import qualified Derive.Call.GraceUtil as GraceUtil
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Flags as Flags
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import           Global
import           Types


generator :: Derive.CallName -> Doc.Doc
    -> Derive.WithArgDoc (Derive.GeneratorF d)
    -> Derive.Generator d
generator :: forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.instrument CallName
name Tags
forall a. Monoid a => a
mempty

generator0 :: Derive.Taggable d => Derive.CallName -> Doc.Doc
    -> (Derive.PassedArgs d -> Derive.Deriver (Stream.Stream d))
    -> Derive.Generator d
generator0 :: forall d.
Taggable d =>
CallName
-> Doc -> (PassedArgs d -> Deriver (Stream d)) -> Generator d
generator0 CallName
name Doc
doc PassedArgs d -> Deriver (Stream d)
call = CallName
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver (Stream d))
-> Generator d
forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name Doc
doc ((PassedArgs d -> Deriver (Stream d))
-> WithArgDoc (PassedArgs d -> Deriver (Stream d))
forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 PassedArgs d -> Deriver (Stream d)
call)

transformer :: Derive.CallName -> Doc.Doc
    -> Derive.WithArgDoc (Derive.TransformerF d) -> Derive.Transformer d
transformer :: forall d.
CallName -> Doc -> WithArgDoc (TransformerF d) -> Transformer d
transformer CallName
name Doc
doc =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.instrument CallName
name Tags
forall a. Monoid a => a
mempty Doc
doc

transformer0 :: Derive.Taggable d => Derive.CallName -> Doc.Doc
    -> Derive.TransformerF d -> Derive.Transformer d
transformer0 :: forall d.
Taggable d =>
CallName -> Doc -> TransformerF d -> Transformer d
transformer0 CallName
name Doc
doc TransformerF d
call =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.instrument CallName
name Tags
forall a. Monoid a => a
mempty Doc
doc (TransformerF d -> WithArgDoc (TransformerF d)
forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t TransformerF d
call)

-- | Make a call that simply calls the default note call with the given attrs.
attributes_note :: Attrs.Attributes -> Derive.Generator Derive.Note
attributes_note :: Attributes -> Generator Event
attributes_note Attributes
attrs =
    CallName
-> Doc -> (PassedArgs Event -> NoteDeriver) -> Generator Event
forall d.
Taggable d =>
CallName
-> Doc -> (PassedArgs d -> Deriver (Stream d)) -> Generator d
generator0 (Text -> CallName
Derive.CallName (Text -> CallName) -> Text -> CallName
forall a b. (a -> b) -> a -> b
$ Text
"attributes_note " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Attributes -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
attrs)
        Doc
"Invoke the default note call with the given attrs." ((PassedArgs Event -> NoteDeriver) -> Generator Event)
-> (PassedArgs Event -> NoteDeriver) -> Generator Event
forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args ->
    Attributes -> NoteDeriver -> NoteDeriver
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs (PassedArgs Event -> NoteDeriver
Call.reapply_note PassedArgs Event
args)

zero_duration_transform :: Doc.Doc
    -> (Derive.NoteArgs -> Derive.NoteDeriver -> Derive.NoteDeriver)
    -> Derive.Generator Derive.Note
zero_duration_transform :: Doc
-> (PassedArgs Event -> NoteDeriver -> NoteDeriver)
-> Generator Event
zero_duration_transform Doc
doc PassedArgs Event -> NoteDeriver -> NoteDeriver
transform = Doc
-> Tags
-> (PassedArgs Event -> NoteDeriver -> NoteDeriver)
-> Generator Event
Note.transformed_note
    (Doc
"A normal note, but modified when it has zero duration: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
doc)
    Tags
forall a. Monoid a => a
mempty ((PassedArgs Event -> NoteDeriver -> NoteDeriver)
 -> Generator Event)
-> (PassedArgs Event -> NoteDeriver -> NoteDeriver)
-> Generator Event
forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args NoteDeriver
deriver ->
        Deriver State Error Bool
-> NoteDeriver -> NoteDeriver -> NoteDeriver
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (PassedArgs Event -> Deriver State Error Bool
forall a. PassedArgs a -> Deriver State Error Bool
is_zero_duration PassedArgs Event
args) (PassedArgs Event -> NoteDeriver -> NoteDeriver
transform PassedArgs Event
args NoteDeriver
deriver) NoteDeriver
deriver

-- | Create a generator that has a different implementation for zero and
-- non-zero duration.
zero_duration :: Derive.CallName -> Doc.Doc
    -> (Derive.NoteArgs -> Derive.NoteDeriver)
    -> (Derive.NoteArgs -> Derive.NoteDeriver) -> Derive.Generator Derive.Note
zero_duration :: CallName
-> Doc
-> (PassedArgs Event -> NoteDeriver)
-> (PassedArgs Event -> NoteDeriver)
-> Generator Event
zero_duration CallName
name Doc
doc PassedArgs Event -> NoteDeriver
zero PassedArgs Event -> NoteDeriver
non_zero = CallName
-> Doc -> (PassedArgs Event -> NoteDeriver) -> Generator Event
forall d.
Taggable d =>
CallName
-> Doc -> (PassedArgs d -> Deriver (Stream d)) -> Generator d
generator0 CallName
name Doc
doc ((PassedArgs Event -> NoteDeriver) -> Generator Event)
-> (PassedArgs Event -> NoteDeriver) -> Generator Event
forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args ->
    Deriver State Error Bool
-> NoteDeriver -> NoteDeriver -> NoteDeriver
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (PassedArgs Event -> Deriver State Error Bool
forall a. PassedArgs a -> Deriver State Error Bool
is_zero_duration PassedArgs Event
args) (PassedArgs Event -> NoteDeriver
zero PassedArgs Event
args) (PassedArgs Event -> NoteDeriver
non_zero PassedArgs Event
args)

is_zero_duration :: Derive.PassedArgs a -> Derive.Deriver Bool
is_zero_duration :: forall a. PassedArgs a -> Deriver State Error Bool
is_zero_duration PassedArgs a
args
    | PassedArgs a -> TrackTime
forall a. PassedArgs a -> TrackTime
Args.duration PassedArgs a
args TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
0 = do
        -- It turns out it's hard to figure out if a note has zero
        -- duration, and isn't just an infer-duration note.
        Stack
stack <- Deriver Stack
Internal.get_stack
        Environ
environ <- Deriver Environ
Derive.get_environ
        Bool
zero <- (RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
==RealTime
0) (RealTime -> Bool)
-> Deriver State Error RealTime -> Deriver State Error Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassedArgs a -> Deriver State Error RealTime
forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_duration PassedArgs a
args
        let flags :: Flags
flags = Bool -> Stack -> Environ -> Flags
Note.note_flags Bool
zero Stack
stack Environ
environ
        Bool -> Deriver State Error Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Deriver State Error Bool)
-> Bool -> Deriver State Error Bool
forall a b. (a -> b) -> a -> b
$ Bool
zero Bool -> Bool -> Bool
&& Bool -> Bool
not (Flags
flags Flags -> Flags -> Bool
`Flags.has` Flags
Flags.infer_duration)
    | Bool
otherwise = Bool -> Deriver State Error Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Just like the default note call, except apply a function to the output.
postproc_note :: Derive.CallName -> Doc.Doc -> (Score.Event -> Score.Event)
    -> Derive.Generator Derive.Note
postproc_note :: CallName -> Doc -> (Event -> Event) -> Generator Event
postproc_note CallName
name Doc
doc Event -> Event
f = CallName
-> Doc
-> Generator Event
-> (NoteDeriver -> NoteDeriver)
-> Generator Event
forall d.
CallName
-> Doc
-> Generator d
-> (Deriver (Stream d) -> Deriver (Stream d))
-> Generator d
postproc_generator CallName
name Doc
doc Generator Event
Note.c_note NoteDeriver -> NoteDeriver
forall {f :: * -> *} {f :: * -> *}.
(Functor f, Functor f) =>
f (f Event) -> f (f Event)
apply
    where apply :: f (f Event) -> f (f Event)
apply f (f Event)
d = (Event -> Event) -> f Event -> f Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> Event
f (f Event -> f Event) -> f (f Event) -> f (f Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f Event)
d

-- | Transform an existing call by applying a function to it.  It gets a new
-- name and the documentation is prepended to the documentation of the original
-- call.
postproc_generator :: Derive.CallName -> Doc.Doc -> Derive.Generator d
    -> (Derive.Deriver (Stream.Stream d) -> Derive.Deriver (Stream.Stream d))
    -> Derive.Generator d
postproc_generator :: forall d.
CallName
-> Doc
-> Generator d
-> (Deriver (Stream d) -> Deriver (Stream d))
-> Generator d
postproc_generator CallName
name Doc
new_doc (Derive.Call CallName
_ CallDoc
old_doc GeneratorFunc d
func) Deriver (Stream d) -> Deriver (Stream d)
f = Derive.Call
    { call_name :: CallName
call_name = CallName
name
    , call_doc :: CallDoc
call_doc = Doc -> CallDoc -> CallDoc
append_doc Doc
new_doc CallDoc
old_doc
    , call_func :: GeneratorFunc d
call_func = GeneratorFunc d
func { gfunc_f :: GeneratorF d
Derive.gfunc_f = Deriver (Stream d) -> Deriver (Stream d)
f (Deriver (Stream d) -> Deriver (Stream d))
-> GeneratorF d -> GeneratorF d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GeneratorFunc d -> GeneratorF d
forall d. GeneratorFunc d -> GeneratorF d
Derive.gfunc_f GeneratorFunc d
func }
    }
    where
    append_doc :: Doc -> CallDoc -> CallDoc
append_doc Doc
text (Derive.CallDoc Module
tags Tags
module_ Doc
doc [ArgDoc]
args) =
        Module -> Tags -> Doc -> [ArgDoc] -> CallDoc
Derive.CallDoc Module
tags Tags
module_ (Doc
doc Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\n" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
text) [ArgDoc]
args

multiple_calls :: [(Expr.Symbol, [Expr.Symbol])]
    -> [(Expr.Symbol, Derive.Generator Derive.Note)]
multiple_calls :: [(Symbol, [Symbol])] -> [(Symbol, Generator Event)]
multiple_calls [(Symbol, [Symbol])]
calls =
    [ (Symbol
call, CallName -> [Symbol] -> Generator Event
multiple_call (Symbol -> CallName
Derive.sym_to_call_name Symbol
call) [Symbol]
subcalls)
    | (Symbol
call, [Symbol]
subcalls) <- [(Symbol, [Symbol])]
calls
    ]

-- | Create a call that just dispatches to other calls.
multiple_call :: Derive.CallName -> [Expr.Symbol]
    -> Derive.Generator Derive.Note
multiple_call :: CallName -> [Symbol] -> Generator Event
multiple_call CallName
name [Symbol]
calls = CallName
-> Doc -> (PassedArgs Event -> NoteDeriver) -> Generator Event
forall d.
Taggable d =>
CallName
-> Doc -> (PassedArgs d -> Deriver (Stream d)) -> Generator d
generator0 CallName
name
    -- I intentionally omit the calls from the doc string, so they will
    -- combine in the call doc.  Presumably the calls are apparent from the
    -- name.
    Doc
"Dispatch to multiple calls." ((PassedArgs Event -> NoteDeriver) -> Generator Event)
-> (PassedArgs Event -> NoteDeriver) -> Generator Event
forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args ->
        (Symbol -> NoteDeriver) -> [Symbol] -> NoteDeriver
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (PassedArgs Event -> Symbol -> NoteDeriver
forall d.
Callable (Generator d) =>
PassedArgs d -> Symbol -> Deriver (Stream d)
Eval.reapply_generator PassedArgs Event
args) [Symbol]
calls

-- | The grace note falls either before or after the beat.
data Placement = Before | After deriving (Int -> Placement -> ShowS
[Placement] -> ShowS
Placement -> String
(Int -> Placement -> ShowS)
-> (Placement -> String)
-> ([Placement] -> ShowS)
-> Show Placement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Placement] -> ShowS
$cshowList :: [Placement] -> ShowS
show :: Placement -> String
$cshow :: Placement -> String
showsPrec :: Int -> Placement -> ShowS
$cshowsPrec :: Int -> Placement -> ShowS
Show, Placement -> Placement -> Bool
(Placement -> Placement -> Bool)
-> (Placement -> Placement -> Bool) -> Eq Placement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Placement -> Placement -> Bool
$c/= :: Placement -> Placement -> Bool
== :: Placement -> Placement -> Bool
$c== :: Placement -> Placement -> Bool
Eq)

doubled_call :: Expr.Symbol -> Derive.CallName -> Placement -> RealTime
    -> Signal.Y -> Derive.Generator Derive.Note
doubled_call :: Symbol -> CallName -> Placement -> RealTime -> Y -> Generator Event
doubled_call Symbol
callee CallName
name Placement
place RealTime
default_time Y
default_dyn_scale = CallName
-> Doc
-> WithArgDoc (PassedArgs Event -> NoteDeriver)
-> Generator Event
forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name
    (Doc
"Doubled call. The grace note falls "
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> (if Placement
place Placement -> Placement -> Bool
forall a. Eq a => a -> a -> Bool
== Placement
Before then Doc
"before" else Doc
"after") Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" the beat.")
    (WithArgDoc (PassedArgs Event -> NoteDeriver) -> Generator Event)
-> WithArgDoc (PassedArgs Event -> NoteDeriver) -> Generator Event
forall a b. (a -> b) -> a -> b
$ Parser (DefaultReal, Y)
-> ((DefaultReal, Y) -> PassedArgs Event -> NoteDeriver)
-> WithArgDoc (PassedArgs Event -> NoteDeriver)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    (DefaultReal -> Y -> (DefaultReal, Y))
-> Parser DefaultReal -> Parser (Y -> (DefaultReal, Y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> DefaultReal -> Doc -> Parser DefaultReal
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
default_time)
        Doc
"Time between the strokes."
    Parser (Y -> (DefaultReal, Y))
-> Parser Y -> Parser (DefaultReal, Y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"dyn" Y
default_dyn_scale Doc
"Dyn scale for the grace note."
    ) (((DefaultReal, Y) -> PassedArgs Event -> NoteDeriver)
 -> WithArgDoc (PassedArgs Event -> NoteDeriver))
-> ((DefaultReal, Y) -> PassedArgs Event -> NoteDeriver)
-> WithArgDoc (PassedArgs Event -> NoteDeriver)
forall a b. (a -> b) -> a -> b
$ \(Typecheck.DefaultReal Duration
time, Y
dyn_scale) -> (PassedArgs Event -> NoteDeriver)
-> PassedArgs Event -> NoteDeriver
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting ((PassedArgs Event -> NoteDeriver)
 -> PassedArgs Event -> NoteDeriver)
-> (PassedArgs Event -> NoteDeriver)
-> PassedArgs Event
-> NoteDeriver
forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> do
        Y
dyn <- RealTime -> Deriver Y
Call.dynamic (RealTime -> Deriver Y)
-> Deriver State Error RealTime -> Deriver Y
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PassedArgs Event -> Deriver State Error RealTime
forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_start PassedArgs Event
args
        let with_dyn :: Deriver a -> Deriver a
with_dyn = Y -> Deriver a -> Deriver a
forall a. Y -> Deriver a -> Deriver a
Call.with_dynamic (Y
dyn Y -> Y -> Y
forall a. Num a => a -> a -> a
* Y
dyn_scale)
        let note :: NoteDeriver
note = PassedArgs Event -> Symbol -> NoteDeriver
forall d.
Callable (Generator d) =>
PassedArgs d -> Symbol -> Deriver (Stream d)
Eval.reapply_generator_normalized PassedArgs Event
args Symbol
callee
        [Event]
notes <- NoteDeriver
-> Int -> Duration -> Y -> PassedArgs Event -> Deriver [Event]
forall a.
NoteDeriver
-> Int -> Duration -> Y -> PassedArgs a -> Deriver [Event]
GraceUtil.repeat_notes NoteDeriver
note Int
2 Duration
time
            (if Placement
place Placement -> Placement -> Bool
forall a. Eq a => a -> a -> Bool
== Placement
Before then Y
0 else Y
1) PassedArgs Event
args
        case [Event]
notes of
            [Event
first, Event
second]
                | Placement
place Placement -> Placement -> Bool
forall a. Eq a => a -> a -> Bool
== Placement
Before -> [Event] -> NoteDeriver
Sub.derive [NoteDeriver -> NoteDeriver
forall {a}. Deriver a -> Deriver a
with_dyn (NoteDeriver -> NoteDeriver) -> Event -> Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event
first, Event
second]
                | Bool
otherwise -> [Event] -> NoteDeriver
Sub.derive [Event
first, NoteDeriver -> NoteDeriver
forall {a}. Deriver a -> Deriver a
with_dyn (NoteDeriver -> NoteDeriver) -> Event -> Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event
second]
            -- Shouldn't happen, because I passed 2 to repeat_notes.
            [Event]
_ -> Text -> NoteDeriver
forall a. Stack => Text -> Deriver a
Derive.throw Text
"expected 2 notes"

-- * composite

composite_doc :: Doc.Doc
composite_doc :: Doc
composite_doc = Doc
"Composite instrument calls create notes for multiple\
    \ instruments, splitting pitch and control signals among them. The\
    \ composite instrument itself doesn't wind up in the output, so it\
    \ should have an empty allocation."

-- | A composite patch corresponds to multiple underlying MIDI patches.
--
-- This is useful for instruments with multiple pitches, e.g. a drum with
-- a keymap for strokes as well as a tuned pitch, or a pitched instrument with
-- a secondary pitch as a resonance.
data Composite = Composite {
    -- | Dispatch to this call.
    Composite -> Symbol
c_call :: !Expr.Symbol
    -- | And this instrument.
    , Composite -> Instrument
c_instrument :: !ScoreT.Instrument
    , Composite -> Pitch
c_pitch :: !Pitch
    , Composite -> Controls
c_controls :: !Controls
    } deriving (Int -> Composite -> ShowS
[Composite] -> ShowS
Composite -> String
(Int -> Composite -> ShowS)
-> (Composite -> String)
-> ([Composite] -> ShowS)
-> Show Composite
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Composite] -> ShowS
$cshowList :: [Composite] -> ShowS
show :: Composite -> String
$cshow :: Composite -> String
showsPrec :: Int -> Composite -> ShowS
$cshowsPrec :: Int -> Composite -> ShowS
Show)

instance Pretty Composite where
    pretty :: Composite -> Text
pretty (Composite Symbol
call Instrument
inst Pitch
pitch Controls
controls) = [Text] -> Text
Text.unwords
        [ Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
inst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":", Symbol -> Text
forall a. Pretty a => a -> Text
pretty Symbol
call, Text
ppitch
        , Text -> (Set Control -> Text) -> Controls -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"(all)" Set Control -> Text
forall a. Pretty a => a -> Text
pretty Controls
controls
        ]
        where
        ppitch :: Text
ppitch = case Pitch
pitch of
            Pitch
NoPitch -> Text
"(no pitch)"
            Pitch PControl
control -> PControl -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val PControl
control

data Pitch = NoPitch | Pitch ScoreT.PControl deriving (Int -> Pitch -> ShowS
[Pitch] -> ShowS
Pitch -> String
(Int -> Pitch -> ShowS)
-> (Pitch -> String) -> ([Pitch] -> ShowS) -> Show Pitch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pitch] -> ShowS
$cshowList :: [Pitch] -> ShowS
show :: Pitch -> String
$cshow :: Pitch -> String
showsPrec :: Int -> Pitch -> ShowS
$cshowsPrec :: Int -> Pitch -> ShowS
Show)
-- | If Nothing, then this Composite gets all the controls that are not given
-- to other instruments.  Otherwise, it only gets the named ones.
type Controls = Maybe (Set ScoreT.Control)

show_controls :: Controls -> Doc.Doc
show_controls :: Controls -> Doc
show_controls = Text -> Doc
Doc.Doc (Text -> Doc) -> (Controls -> Text) -> Controls -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Set Control -> Text) -> Controls -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"(all)" Set Control -> Text
forall a. Pretty a => a -> Text
pretty

redirect_pitch :: Derive.CallName -> Expr.Symbol -> Controls
    -> Expr.Symbol -> Controls -> Derive.Generator Derive.Note
redirect_pitch :: CallName
-> Symbol -> Controls -> Symbol -> Controls -> Generator Event
redirect_pitch CallName
name Symbol
pitched_call Controls
pitched_controls Symbol
unpitched_call
        Controls
unpitched_controls =
    CallName
-> Doc
-> WithArgDoc (PassedArgs Event -> NoteDeriver)
-> Generator Event
forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name (Doc
"A composite instrument splits pitch and controls to\
        \ separate instruments.\n" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
composite_doc)
    (WithArgDoc (PassedArgs Event -> NoteDeriver) -> Generator Event)
-> WithArgDoc (PassedArgs Event -> NoteDeriver) -> Generator Event
forall a b. (a -> b) -> a -> b
$ Parser (Instrument, Instrument)
-> ((Instrument, Instrument) -> PassedArgs Event -> NoteDeriver)
-> WithArgDoc (PassedArgs Event -> NoteDeriver)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    (Instrument -> Instrument -> (Instrument, Instrument))
-> Parser Instrument
-> Parser (Instrument -> (Instrument, Instrument))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> EnvironDefault -> Doc -> Parser Instrument
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ ArgName
"pitched" EnvironDefault
Sig.Prefixed
        (Doc
"This instrument gets the pitch signal and controls: "
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Controls -> Doc
show_controls Controls
pitched_controls)
    Parser (Instrument -> (Instrument, Instrument))
-> Parser Instrument -> Parser (Instrument, Instrument)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> Doc -> Parser Instrument
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ ArgName
"unpitched" EnvironDefault
Sig.Prefixed
        (Doc
"This instrument gets controls: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Controls -> Doc
show_controls Controls
unpitched_controls)
    ) (((Instrument, Instrument) -> PassedArgs Event -> NoteDeriver)
 -> WithArgDoc (PassedArgs Event -> NoteDeriver))
-> ((Instrument, Instrument) -> PassedArgs Event -> NoteDeriver)
-> WithArgDoc (PassedArgs Event -> NoteDeriver)
forall a b. (a -> b) -> a -> b
$ \(Instrument
pitched, Instrument
unpitched) -> (PassedArgs Event -> NoteDeriver)
-> PassedArgs Event -> NoteDeriver
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting ((PassedArgs Event -> NoteDeriver)
 -> PassedArgs Event -> NoteDeriver)
-> (PassedArgs Event -> NoteDeriver)
-> PassedArgs Event
-> NoteDeriver
forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> PassedArgs Event -> [Composite] -> NoteDeriver
composite_call PassedArgs Event
args
        [ Symbol -> Instrument -> Pitch -> Controls -> Composite
Composite Symbol
pitched_call Instrument
pitched (PControl -> Pitch
Pitch PControl
ScoreT.default_pitch)
            Controls
pitched_controls
        , Symbol -> Instrument -> Pitch -> Controls -> Composite
Composite Symbol
unpitched_call Instrument
unpitched Pitch
NoPitch Controls
unpitched_controls
        ]

double_pitch :: Derive.CallName -> Controls -> ScoreT.PControl -> Controls
    -> Derive.Generator Derive.Note
double_pitch :: CallName -> Controls -> PControl -> Controls -> Generator Event
double_pitch CallName
name Controls
base_controls PControl
pcontrol Controls
secondary_controls =
    CallName
-> Doc
-> WithArgDoc (PassedArgs Event -> NoteDeriver)
-> Generator Event
forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name (Doc
"A composite instrument that has two pitch signals.\n"
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
composite_doc)
    (WithArgDoc (PassedArgs Event -> NoteDeriver) -> Generator Event)
-> WithArgDoc (PassedArgs Event -> NoteDeriver) -> Generator Event
forall a b. (a -> b) -> a -> b
$ Parser (Instrument, Instrument)
-> ((Instrument, Instrument) -> PassedArgs Event -> NoteDeriver)
-> WithArgDoc (PassedArgs Event -> NoteDeriver)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    (Instrument -> Instrument -> (Instrument, Instrument))
-> Parser Instrument
-> Parser (Instrument -> (Instrument, Instrument))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> EnvironDefault -> Doc -> Parser Instrument
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ ArgName
"base-inst" EnvironDefault
Sig.Prefixed
        (Doc
"Instrument that gets `#`, and controls: "
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Controls -> Doc
show_controls Controls
base_controls)
    Parser (Instrument -> (Instrument, Instrument))
-> Parser Instrument -> Parser (Instrument, Instrument)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> Doc -> Parser Instrument
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ ArgName
"second-inst" EnvironDefault
Sig.Prefixed
        (Doc
"Instrument that gets " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PControl -> Doc
forall a. ShowVal a => a -> Doc
ShowVal.doc PControl
pcontrol
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
", and controls: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Controls -> Doc
show_controls Controls
secondary_controls)
    ) (((Instrument, Instrument) -> PassedArgs Event -> NoteDeriver)
 -> WithArgDoc (PassedArgs Event -> NoteDeriver))
-> ((Instrument, Instrument) -> PassedArgs Event -> NoteDeriver)
-> WithArgDoc (PassedArgs Event -> NoteDeriver)
forall a b. (a -> b) -> a -> b
$ \(Instrument
inst1, Instrument
inst2) -> (PassedArgs Event -> NoteDeriver)
-> PassedArgs Event -> NoteDeriver
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting ((PassedArgs Event -> NoteDeriver)
 -> PassedArgs Event -> NoteDeriver)
-> (PassedArgs Event -> NoteDeriver)
-> PassedArgs Event
-> NoteDeriver
forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> PassedArgs Event -> [Composite] -> NoteDeriver
composite_call PassedArgs Event
args
        [ Symbol -> Instrument -> Pitch -> Controls -> Composite
Composite Symbol
"" Instrument
inst1 (PControl -> Pitch
Pitch PControl
ScoreT.default_pitch) Controls
base_controls
        , Symbol -> Instrument -> Pitch -> Controls -> Composite
Composite Symbol
"" Instrument
inst2 (PControl -> Pitch
Pitch PControl
pcontrol) Controls
secondary_controls
        ]

composite_call :: Derive.NoteArgs -> [Composite] -> Derive.NoteDeriver
composite_call :: PassedArgs Event -> [Composite] -> NoteDeriver
composite_call PassedArgs Event
args [Composite]
composites = (Composite -> NoteDeriver) -> [Composite] -> NoteDeriver
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (PassedArgs Event -> Composite -> NoteDeriver
forall {d}.
Callable (Generator d) =>
PassedArgs d -> Composite -> Deriver (Stream d)
split PassedArgs Event
args) [Composite]
composites
    where
    allocated :: Set Control
allocated = (Composite -> Set Control) -> [Composite] -> Set Control
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (Set Control -> Controls -> Set Control
forall a. a -> Maybe a -> a
fromMaybe Set Control
forall a. Monoid a => a
mempty (Controls -> Set Control)
-> (Composite -> Controls) -> Composite -> Set Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Composite -> Controls
c_controls) [Composite]
composites
    split :: PassedArgs d -> Composite -> Deriver (Stream d)
split PassedArgs d
args (Composite Symbol
call Instrument
inst Pitch
pitch Controls
controls) =
        Instrument -> Deriver (Stream d) -> Deriver (Stream d)
forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Instrument
inst (Deriver (Stream d) -> Deriver (Stream d))
-> Deriver (Stream d) -> Deriver (Stream d)
forall a b. (a -> b) -> a -> b
$ Pitch -> Deriver (Stream d) -> Deriver (Stream d)
forall {a}. Pitch -> Deriver a -> Deriver a
with_pitch Pitch
pitch (Deriver (Stream d) -> Deriver (Stream d))
-> Deriver (Stream d) -> Deriver (Stream d)
forall a b. (a -> b) -> a -> b
$
        Controls -> Deriver (Stream d) -> Deriver (Stream d)
forall {b}. Controls -> Deriver b -> Deriver b
with_controls Controls
controls (Deriver (Stream d) -> Deriver (Stream d))
-> Deriver (Stream d) -> Deriver (Stream d)
forall a b. (a -> b) -> a -> b
$ PassedArgs d -> Symbol -> Deriver (Stream d)
forall d.
Callable (Generator d) =>
PassedArgs d -> Symbol -> Deriver (Stream d)
Eval.reapply_generator PassedArgs d
args Symbol
call
    with_pitch :: Pitch -> Deriver a -> Deriver a
with_pitch Pitch
p Deriver a
deriver = case Pitch
p of
        Pitch
NoPitch -> PSignal -> Deriver a -> Deriver a
forall a. PSignal -> Deriver a -> Deriver a
Derive.with_pitch PSignal
forall a. Monoid a => a
mempty Deriver a
deriver
        Pitch PControl
control
            | PControl
control PControl -> PControl -> Bool
forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch -> Deriver a
deriver
            | Bool
otherwise -> do
                Maybe PSignal
sig <- PControl -> Deriver (Maybe PSignal)
Derive.get_named_pitch PControl
control
                PSignal -> Deriver a -> Deriver a
forall a. PSignal -> Deriver a -> Deriver a
Derive.with_pitch (PSignal -> Maybe PSignal -> PSignal
forall a. a -> Maybe a -> a
fromMaybe PSignal
forall a. Monoid a => a
mempty Maybe PSignal
sig) Deriver a
deriver
    with_controls :: Controls -> Deriver b -> Deriver b
with_controls Controls
controls Deriver b
deriver = do
        ControlMap
cmap <- Deriver ControlMap
Derive.get_controls
        ControlFunctionMap
cfuncs <- Deriver ControlFunctionMap
Derive.get_control_functions
        let strip :: Map Control a -> Map Control a
strip = (Control -> a -> Bool) -> Map Control a -> Map Control a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey ((Control -> a -> Bool) -> Map Control a -> Map Control a)
-> (Control -> a -> Bool) -> Map Control a -> Map Control a
forall a b. (a -> b) -> a -> b
$ \Control
control a
_ -> Bool -> (Set Control -> Bool) -> Controls -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (Control -> Set Control -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember Control
control Set Control
allocated) (Control -> Set Control -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Control
control) Controls
controls
        ControlMap -> ControlFunctionMap -> Deriver b -> Deriver b
forall a.
ControlMap -> ControlFunctionMap -> Deriver a -> Deriver a
Derive.with_control_maps (ControlMap -> ControlMap
forall {a}. Map Control a -> Map Control a
strip ControlMap
cmap) (ControlFunctionMap -> ControlFunctionMap
forall {a}. Map Control a -> Map Control a
strip ControlFunctionMap
cfuncs) Deriver b
deriver


-- * control vals

constant_pitch :: Derive.Generator Derive.Note
constant_pitch :: Generator Event
constant_pitch = Bool -> Set Control -> Generator Event
constant_controls Bool
True Set Control
forall a. Monoid a => a
mempty

constant_controls :: Bool -> Set ScoreT.Control -> Derive.Generator Derive.Note
constant_controls :: Bool -> Set Control -> Generator Event
constant_controls Bool
constant_pitch Set Control
controls =
    Doc
-> Tags
-> (PassedArgs Event -> NoteDeriver -> NoteDeriver)
-> Generator Event
Note.transformed_note Doc
doc Tags
forall a. Monoid a => a
mempty ((PassedArgs Event -> NoteDeriver -> NoteDeriver)
 -> Generator Event)
-> (PassedArgs Event -> NoteDeriver -> NoteDeriver)
-> Generator Event
forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args ->
        (if Bool
constant_pitch then PassedArgs Event -> NoteDeriver -> NoteDeriver
forall b a. PassedArgs b -> Deriver a -> Deriver a
set_constant_pitch PassedArgs Event
args else NoteDeriver -> NoteDeriver
forall a. a -> a
id)
        (NoteDeriver -> NoteDeriver)
-> (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Control -> PassedArgs Event -> NoteDeriver -> NoteDeriver
forall b a. Set Control -> PassedArgs b -> Deriver a -> Deriver a
set_constant_controls Set Control
controls PassedArgs Event
args
    where
    doc :: Doc
doc = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Doc
"Notes have a constant pitch, sampled at attack time."
            | Bool
constant_pitch]
        , [ Doc
"These controls are sampled at attack time, which means they work\
                \ with ControlFunctions: "
                Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
Doc.commas ((Control -> Doc) -> [Control] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Control -> Doc
forall a. Pretty a => a -> Doc
Doc.pretty (Set Control -> [Control]
forall a. Set a -> [a]
Set.toList Set Control
controls)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
".\n"
            | Bool -> Bool
not (Set Control -> Bool
forall a. Set a -> Bool
Set.null Set Control
controls)
          ]
        ]

set_constant_controls :: Set ScoreT.Control -> Derive.PassedArgs b
    -> Derive.Deriver a -> Derive.Deriver a
set_constant_controls :: forall b a. Set Control -> PassedArgs b -> Deriver a -> Deriver a
set_constant_controls Set Control
controls PassedArgs b
args Deriver a
deriver
    | Set Control -> Bool
forall a. Set a -> Bool
Set.null Set Control
controls = Deriver a
deriver
    | Bool
otherwise = do
        ControlValMap
vals <- RealTime -> Deriver ControlValMap
Derive.controls_at (RealTime -> Deriver ControlValMap)
-> Deriver State Error RealTime -> Deriver ControlValMap
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PassedArgs b -> Deriver State Error RealTime
forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_start PassedArgs b
args
        let sampled :: Map Control (Typed (Signal kind))
sampled = Signal kind -> Typed (Signal kind)
forall a. a -> Typed a
ScoreT.untyped (Signal kind -> Typed (Signal kind))
-> (Y -> Signal kind) -> Y -> Typed (Signal kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Signal kind
forall {k} (kind :: k). Y -> Signal kind
Signal.constant (Y -> Typed (Signal kind))
-> ControlValMap -> Map Control (Typed (Signal kind))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                (Control -> Y -> Bool) -> ControlValMap -> ControlValMap
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Control
k Y
_ -> Control
k Control -> Set Control -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Control
controls) ControlValMap
vals
        [(Control, Typed Control)] -> Deriver a -> Deriver a
forall a. [(Control, Typed Control)] -> Deriver a -> Deriver a
Derive.with_controls (ControlMap -> [(Control, Typed Control)]
forall k a. Map k a -> [(k, a)]
Map.toList ControlMap
forall {k} {kind :: k}. Map Control (Typed (Signal kind))
sampled) Deriver a
deriver

set_constant_pitch :: Derive.PassedArgs b -> Derive.Deriver a
    -> Derive.Deriver a
set_constant_pitch :: forall b a. PassedArgs b -> Deriver a -> Deriver a
set_constant_pitch PassedArgs b
args Deriver a
deriver = do
    Maybe Pitch
pitch <- RealTime -> Deriver (Maybe Pitch)
Derive.pitch_at (RealTime -> Deriver (Maybe Pitch))
-> Deriver State Error RealTime -> Deriver (Maybe Pitch)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PassedArgs b -> Deriver State Error RealTime
forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_start PassedArgs b
args
    case Maybe Pitch
pitch of
        Maybe Pitch
Nothing -> Deriver a
deriver
        Just Pitch
pitch -> Pitch -> Deriver a -> Deriver a
forall a. Pitch -> Deriver a -> Deriver a
Derive.with_constant_pitch Pitch
pitch (Deriver a -> Deriver a) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$
            Set Control -> PassedArgs b -> Deriver a -> Deriver a
forall b a. Set Control -> PassedArgs b -> Deriver a -> Deriver a
set_constant_controls Set Control
transposers PassedArgs b
args Deriver a
deriver
            where
            transposers :: Set Control
transposers = Scale -> Set Control
PSignal.pscale_transposers (Pitch -> Scale
forall a. RawPitch a -> Scale
PSignal.pitch_scale Pitch
pitch)

-- * postproc

element_from :: (Typecheck.Typecheck old, Typecheck.ToVal new) => EnvKey.Key
    -> (old -> Either Log.Msg new) -> Cmd.InstrumentPostproc
element_from :: forall old new.
(Typecheck old, ToVal new) =>
Text -> (old -> Either Msg new) -> InstrumentPostproc
element_from Text
key = Text -> Text -> (old -> Either Msg new) -> InstrumentPostproc
forall old new.
(Typecheck old, ToVal new) =>
Text -> Text -> (old -> Either Msg new) -> InstrumentPostproc
move_val Text
key Text
EnvKey.element

element_from_id :: EnvKey.Key -> Cmd.InstrumentPostproc
element_from_id :: Text -> InstrumentPostproc
element_from_id Text
key =
    Text -> Text -> (Val -> Either Msg Val) -> InstrumentPostproc
forall old new.
(Typecheck old, ToVal new) =>
Text -> Text -> (old -> Either Msg new) -> InstrumentPostproc
move_val Text
key Text
EnvKey.element (\Val
v -> Val -> Either Msg Val
forall a b. b -> Either a b
Right (Val
v :: DeriveT.Val))

-- | Move an environ val from one key to another.  This is meant to be put in
-- 'Cmd.Cmd.inst_postproc', because doing it in the note call may be too early.
move_val :: (Typecheck.Typecheck old, Typecheck.ToVal new) => EnvKey.Key
    -> EnvKey.Key -> (old -> Either Log.Msg new) -> Cmd.InstrumentPostproc
move_val :: forall old new.
(Typecheck old, ToVal new) =>
Text -> Text -> (old -> Either Msg new) -> InstrumentPostproc
move_val Text
old_key Text
new_key old -> Either Msg new
convert Event
event =
    case Text -> Environ -> Maybe (Either Text old)
forall a. Typecheck a => Text -> Environ -> Maybe (Either Text a)
Env.checked_val2 Text
old_key (Event -> Environ
Score.event_environ Event
event) of
        Maybe (Either Text old)
Nothing -> (Event
event, [])
        Just (Left Text
err) -> (Event
event, [Msg
msg])
            where
            msg :: Msg
msg = Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn (Stack -> Maybe Stack
forall a. a -> Maybe a
Just (Event -> Stack
Score.event_stack Event
event)) (Text -> Msg) -> Text -> Msg
forall a b. (a -> b) -> a -> b
$
                Text
"postproc: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
        Just (Right old
old) -> case old -> Either Msg new
convert old
old of
            Left Msg
msg ->
                ( Event
event
                , [Msg
msg { msg_stack :: Maybe Stack
Log.msg_stack = Stack -> Maybe Stack
forall a. a -> Maybe a
Just (Stack -> Maybe Stack) -> Stack -> Maybe Stack
forall a b. (a -> b) -> a -> b
$ Event -> Stack
Score.event_stack Event
event }]
                )
            Right new
new ->
                ((Environ -> Environ) -> Event -> Event
Score.modify_environ (Text -> new -> Environ -> Environ
forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
new_key new
new) Event
event, [])

with_symbolic_pitch :: Cmd.InstrumentPostproc
with_symbolic_pitch :: InstrumentPostproc
with_symbolic_pitch = Text -> Maybe Bool -> InstrumentPostproc -> InstrumentPostproc
forall val.
(Eq val, Typecheck val) =>
Text -> Maybe val -> InstrumentPostproc -> InstrumentPostproc
when_env Text
"symbolic-pitch" (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) InstrumentPostproc
add_symbolic_pitch

add_symbolic_pitch :: Cmd.InstrumentPostproc
add_symbolic_pitch :: InstrumentPostproc
add_symbolic_pitch =
    (Transposed -> Either Text Note) -> InstrumentPostproc
add_symbolic_pitch_convert ((PitchError -> Text) -> Either PitchError Note -> Either Text Note
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PitchError -> Text
forall a. Pretty a => a -> Text
pretty (Either PitchError Note -> Either Text Note)
-> (Transposed -> Either PitchError Note)
-> Transposed
-> Either Text Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Either PitchError Note
PSignal.pitch_note)

add_symbolic_pitch_convert :: (PSignal.Transposed -> Either Text Pitch.Note)
    -> Cmd.InstrumentPostproc
add_symbolic_pitch_convert :: (Transposed -> Either Text Note) -> InstrumentPostproc
add_symbolic_pitch_convert Transposed -> Either Text Note
convert Event
event = LogId Event -> (Event, [Msg])
forall a. LogId a -> (a, [Msg])
Log.run_id (LogId Event -> (Event, [Msg])) -> LogId Event -> (Event, [Msg])
forall a b. (a -> b) -> a -> b
$
    case RealTime -> Event -> Maybe Transposed
Score.transposed_at (Event -> RealTime
Score.event_start Event
event) Event
event of
        Maybe Transposed
Nothing -> do
            Text -> LogT Identity ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> LogT Identity ()) -> Text -> LogT Identity ()
forall a b. (a -> b) -> a -> b
$ Text
"no symbolic pitch for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Event -> Text
Score.short_event Event
event
            Event -> LogId Event
forall (m :: * -> *) a. Monad m => a -> m a
return Event
event
        Just Transposed
pitch -> case Transposed -> Either Text Note
convert Transposed
pitch of
            Left Text
err -> do
                Text -> LogT Identity ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> LogT Identity ()) -> Text -> LogT Identity ()
forall a b. (a -> b) -> a -> b
$ Text
"converting symbolic pitch for "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Event -> Text
Score.short_event Event
event Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
                Event -> LogId Event
forall (m :: * -> *) a. Monad m => a -> m a
return Event
event
            Right Note
note ->
                Event -> LogId Event
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> LogId Event) -> Event -> LogId Event
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Event -> Event
forall key. ToVal key => Text -> key -> Event -> Event
set_environ Text
EnvKey.element (Note -> Text
Pitch.note_text Note
note) Event
event

set_environ :: Typecheck.ToVal key => EnvKey.Key -> key -> Score.Event
    -> Score.Event
set_environ :: forall key. ToVal key => Text -> key -> Event -> Event
set_environ Text
key key
val =
    Text -> (Maybe Val -> Val) -> Event -> Event
Score.modify_environ_key Text
key (Val -> Maybe Val -> Val
forall a b. a -> b -> a
const (key -> Val
forall a. ToVal a => a -> Val
Typecheck.to_val key
val))

when_env :: (Eq val, Typecheck.Typecheck val) => EnvKey.Key -> Maybe val
    -> Cmd.InstrumentPostproc -> Cmd.InstrumentPostproc
when_env :: forall val.
(Eq val, Typecheck val) =>
Text -> Maybe val -> InstrumentPostproc -> InstrumentPostproc
when_env Text
key Maybe val
val InstrumentPostproc
postproc Event
event
    | Maybe val
val Maybe val -> Maybe val -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Environ -> Maybe val
forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
key (Event -> Environ
Score.event_environ Event
event) = InstrumentPostproc
postproc Event
event
    | Bool
otherwise = (Event
event, [])