-- 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

-- | Block call and support.
module Derive.C.Prelude.Block (
    library
    , eval_root_block, global_transform
) where
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map

import qualified Derive.Args as Args
import qualified Derive.Cache as Cache
import qualified Derive.Call.BlockUtil as BlockUtil
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Score as Score
import qualified Derive.Sig as Sig
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream

import qualified Perform.Signal as Signal
import qualified Ui.Block as Block
import qualified Ui.Event as Event
import qualified Ui.Id as Id
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


library :: Library.Library
library :: Library
library = [Library] -> Library
forall a. Monoid a => [a] -> a
mconcat
    [ [(Symbol, Generator Note)] -> Library
forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [(Symbol
BlockUtil.capture_null_control, Generator Note
c_capture_null_control)]
    , PatternCall (Generator Note) -> Library
forall call. ToLibrary call => PatternCall call -> Library
Library.pattern PatternCall (Generator Note)
pattern_note_block
    , PatternCall (Generator Control) -> Library
forall call. ToLibrary call => PatternCall call -> Library
Library.pattern PatternCall (Generator Control)
pattern_control_block
    ]

-- * root block

-- | Evaluate the root block in a performance.  Making this an ordinary call
-- means it participates in the derive cache just like all other calls.
--
-- Tempo.with_tempo does a bit of magic to stretch all blocks to length 1,
-- except the root one.  The root block should operate in real time, so no
-- stretching here.  Otherwise, a tempo of 2 would be the same as 1.
{-# SCC eval_root_block #-}
eval_root_block :: BlockId -> Derive.NoteDeriver
eval_root_block :: BlockId -> NoteDeriver
eval_root_block BlockId
block_id =
    NoteDeriver -> NoteDeriver
global_transform (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Bool -> Call -> NoteDeriver
forall d. CallableExpr d => Bool -> Call -> Deriver (Stream d)
Eval.eval_one_call Bool
True (Call -> NoteDeriver) -> Call -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ BlockId -> Call
call_from_block_id BlockId
block_id

{-# SCC global_transform #-}
global_transform :: Derive.NoteDeriver -> Derive.NoteDeriver
global_transform :: NoteDeriver -> NoteDeriver
global_transform = Context Note -> Symbol -> NoteDeriver -> NoteDeriver
forall a.
Callable (Transformer a) =>
Context a -> Symbol -> Deriver (Stream a) -> Deriver (Stream a)
transform_if_present Context Note
forall {a}. Context a
ctx Symbol
"GLOBAL"
    where ctx :: Context a
ctx = ScoreTime -> ScoreTime -> Text -> Context a
forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
0 ScoreTime
1 Text
"<GLOBAL transform>"

transform_if_present :: Derive.Callable (Derive.Transformer a)
    => Derive.Context a
    -> Expr.Symbol -> Derive.Deriver (Stream.Stream a)
    -> Derive.Deriver (Stream.Stream a)
transform_if_present :: forall a.
Callable (Transformer a) =>
Context a -> Symbol -> Deriver (Stream a) -> Deriver (Stream a)
transform_if_present Context a
ctx Symbol
sym Deriver (Stream a)
deriver = Symbol -> Deriver (Maybe (Transformer a))
forall call. Callable call => Symbol -> Deriver (Maybe call)
Derive.lookup_call Symbol
sym Deriver (Maybe (Transformer a))
-> (Maybe (Transformer a) -> Deriver (Stream a))
-> Deriver (Stream a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Transformer a)
Nothing -> Deriver (Stream a)
deriver
    Just Transformer a
call -> Context a
-> Transformer a
-> [Val]
-> Deriver (Stream a)
-> Deriver (Stream a)
forall d.
Context d
-> Transformer d
-> [Val]
-> Deriver (Stream d)
-> Deriver (Stream d)
Eval.apply_transformer Context a
ctx Transformer a
call [] Deriver (Stream a)
deriver

-- * note calls

pattern_note_block :: Derive.PatternCall (Derive.Generator Derive.Note)
pattern_note_block :: PatternCall (Generator Note)
pattern_note_block = Derive.PatternCall
    { pat_description :: Text
pat_description = Text
"block name"
    , pat_doc :: DocumentedCall
pat_doc = Generator Note -> DocumentedCall
forall d. Call d -> DocumentedCall
Derive.extract_doc Generator Note
fake_call
    , pat_function :: Symbol -> Deriver (Maybe (Generator Note))
pat_function = \Symbol
sym -> (BlockId -> Generator Note)
-> Maybe BlockId -> Maybe (Generator Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockId -> Generator Note
c_block (Maybe BlockId -> Maybe (Generator Note))
-> Deriver State Error (Maybe BlockId)
-> Deriver (Maybe (Generator Note))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbol -> Deriver State Error (Maybe BlockId)
call_to_block_id Symbol
sym
    }
    where
    -- Not evaluated, so it doesn't matter if the BlockId is invalid.
    fake_call :: Generator Note
fake_call = BlockId -> Generator Note
c_block (Id -> BlockId
Id.BlockId (Text -> Id
Id.read_id Text
"example/block"))

{-# SCC c_block #-}
c_block :: BlockId -> Derive.Generator Derive.Note
c_block :: BlockId -> Generator Note
c_block BlockId
block_id = (PassedArgs Note -> Deriver (CallDuration ScoreTime))
-> Generator Note -> Generator Note
forall d.
(PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
Derive.with_score_duration PassedArgs Note -> Deriver (CallDuration ScoreTime)
forall a. a -> Deriver (CallDuration ScoreTime)
get_score_duration (Generator Note -> Generator Note)
-> Generator Note -> Generator Note
forall a b. (a -> b) -> a -> b
$
    (PassedArgs Note -> Deriver (CallDuration RealTime))
-> Generator Note -> Generator Note
forall d.
(PassedArgs d -> Deriver (CallDuration RealTime))
-> Generator d -> Generator d
Derive.with_real_duration (Deriver (CallDuration RealTime)
-> PassedArgs Note -> Deriver (CallDuration RealTime)
forall a b. a -> b -> a
const (Deriver (CallDuration RealTime)
 -> PassedArgs Note -> Deriver (CallDuration RealTime))
-> Deriver (CallDuration RealTime)
-> PassedArgs Note
-> Deriver (CallDuration RealTime)
forall a b. (a -> b) -> a -> b
$ BlockId -> Deriver (CallDuration RealTime)
get_real_duration BlockId
block_id) (Generator Note -> Generator Note)
-> Generator Note -> Generator Note
forall a b. (a -> b) -> a -> b
$
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude
        (Text -> CallName
Derive.CallName (Text -> CallName) -> Text -> CallName
forall a b. (a -> b) -> a -> b
$ Text
"block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
forall a. Show a => a -> Text
showt BlockId
block_id) Tags
Tags.prio_block
    Doc
"Substitute the named block into the score. If the symbol doesn't contain\
    \ a `/`, the default namespace is applied. If it starts with a `-`, this\
    \ is a relative call and the calling block's namespace and name are\
    \ prepended."
    (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ GeneratorF Note -> WithArgDoc (GeneratorF Note)
forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 (GeneratorF Note -> WithArgDoc (GeneratorF Note))
-> GeneratorF Note -> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ GeneratorF Note -> GeneratorF Note
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting (GeneratorF Note -> GeneratorF Note)
-> GeneratorF Note -> GeneratorF Note
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Stack
stack <- Deriver Stack
Internal.get_stack
        Bool -> Deriver State Error () -> Deriver State Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockId -> Frame
Stack.Block BlockId
block_id Frame -> [Frame] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Stack -> [Frame]
Stack.innermost Stack
stack) (Deriver State Error () -> Deriver State Error ())
-> Deriver State Error () -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$
            Text -> Deriver State Error ()
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver State Error ()) -> Text -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Text
"recursive call to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
forall a. Pretty a => a -> Text
pretty BlockId
block_id
        -- This ensures that each block call from the same event sees a new
        -- serial number, as documented in 'Derive.CacheKey'.
        Deriver State Error ()
Internal.increment_event_serial
        -- I have to put the block on the stack before calling 'd_block'
        -- because 'Cache.block' relies on on the block id already being
        -- on the stack.
        BlockId -> NoteDeriver -> NoteDeriver
forall a. BlockId -> Deriver a -> Deriver a
Internal.with_stack_block BlockId
block_id (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ BlockId -> GeneratorF Note -> GeneratorF Note
forall d.
BlockId
-> (PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Cache.block BlockId
block_id GeneratorF Note
forall {a}. PassedArgs a -> NoteDeriver
run PassedArgs Note
args
    where
    run :: PassedArgs a -> NoteDeriver
run PassedArgs a
args = ScoreTime -> ScoreTime -> NoteDeriver -> NoteDeriver
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start (ScoreTime
end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
start) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ PassedArgs a -> NoteDeriver -> NoteDeriver
forall {a} {b}. PassedArgs a -> Deriver b -> Deriver b
trim PassedArgs a
args (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ BlockId -> NoteDeriver
d_block BlockId
block_id
        where (ScoreTime
start, ScoreTime
end) = PassedArgs a -> (ScoreTime, ScoreTime)
forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs a
args
    trim :: PassedArgs a -> Deriver b -> Deriver b
trim PassedArgs a
args Deriver b
deriver = do
        RealTime
end <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (ScoreTime
1 :: ScoreTime)
        if Event -> Bool
Event.is_positive (PassedArgs a -> Event
forall a. PassedArgs a -> Event
Args.event PassedArgs a
args)
            then RealTime -> Deriver b -> Deriver b
forall a. RealTime -> Deriver a -> Deriver a
trim_controls RealTime
end Deriver b
deriver
            else Deriver b
deriver
    get_score_duration :: a -> Derive.Deriver (Derive.CallDuration ScoreTime)
    get_score_duration :: forall a. a -> Deriver (CallDuration ScoreTime)
get_score_duration a
_ = ScoreTime -> CallDuration ScoreTime
forall a. a -> CallDuration a
Derive.CallDuration (ScoreTime -> CallDuration ScoreTime)
-> ((ScoreTime, ScoreTime) -> ScoreTime)
-> (ScoreTime, ScoreTime)
-> CallDuration ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(ScoreTime
s, ScoreTime
e) -> ScoreTime
eScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
-ScoreTime
s) ((ScoreTime, ScoreTime) -> CallDuration ScoreTime)
-> Deriver State Error (ScoreTime, ScoreTime)
-> Deriver (CallDuration ScoreTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        BlockId -> Deriver State Error (ScoreTime, ScoreTime)
Derive.block_logical_range BlockId
block_id
    get_real_duration :: BlockId
        -> Derive.Deriver (Derive.CallDuration RealTime)
    get_real_duration :: BlockId -> Deriver (CallDuration RealTime)
get_real_duration BlockId
block_id = (Either Error (CallDuration RealTime) -> CallDuration RealTime)
-> Deriver State Error (Either Error (CallDuration RealTime))
-> Deriver (CallDuration RealTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Error -> CallDuration RealTime)
-> (CallDuration RealTime -> CallDuration RealTime)
-> Either Error (CallDuration RealTime)
-> CallDuration RealTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CallDuration RealTime -> Error -> CallDuration RealTime
forall a b. a -> b -> a
const CallDuration RealTime
forall a. CallDuration a
Derive.Unknown) CallDuration RealTime -> CallDuration RealTime
forall a. a -> a
id) (Deriver State Error (Either Error (CallDuration RealTime))
 -> Deriver (CallDuration RealTime))
-> Deriver State Error (Either Error (CallDuration RealTime))
-> Deriver (CallDuration RealTime)
forall a b. (a -> b) -> a -> b
$
        NoteDeriver
-> Deriver State Error (Either Error (CallDuration RealTime))
forall a.
Deriver a
-> Deriver State Error (Either Error (CallDuration RealTime))
Derive.get_real_duration (NoteDeriver
 -> Deriver State Error (Either Error (CallDuration RealTime)))
-> NoteDeriver
-> Deriver State Error (Either Error (CallDuration RealTime))
forall a b. (a -> b) -> a -> b
$ BlockId -> NoteDeriver -> NoteDeriver
forall a. BlockId -> Deriver a -> Deriver a
Internal.with_stack_block BlockId
block_id (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
            BlockId -> NoteDeriver
d_block BlockId
block_id

-- | Remove samples at the given RealTime.  This is to support final block
-- notes and 'Derive.Flags.infer_duration'.  Otherwise, an event at the end of
-- a block will pick up controls (e.g. a transposition change) that is meant to
-- start at the beginning of the next block.
--
-- However, I can't trim the signal entirely because I still want the control
-- signals past the end of the block to be visible to non-final events.  The
-- problem is that I do want control samples at the end time to be visible
-- if they are interior to the block.  So I need a way to tell the difference
-- between controls from the caller and local ones, so a final event can
-- exclude the former and include the latter.
--
-- TODO this is unsatisfying because it feels ad-hoc and clunky.  In addition,
-- it drops a sample that I don't actually want to drop for non-final events.
-- Not to mention it's inefficient.
trim_controls :: RealTime -> Derive.Deriver a -> Derive.Deriver a
trim_controls :: forall a. RealTime -> Deriver a -> Deriver a
trim_controls RealTime
end = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
dyn -> Dynamic
dyn
    { state_controls :: ControlMap
Derive.state_controls = (Control -> Control) -> Typed Control -> Typed Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> Control -> Control
Signal.drop_discontinuity_at RealTime
end) (Typed Control -> Typed Control) -> ControlMap -> ControlMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Dynamic -> ControlMap
Derive.state_controls Dynamic
dyn
    , state_pitch :: Pitch
Derive.state_pitch =
        RealTime -> Pitch -> Pitch
PSignal.drop_discontinuity_at RealTime
end (Dynamic -> Pitch
Derive.state_pitch Dynamic
dyn)
    , state_pitches :: PitchMap
Derive.state_pitches = RealTime -> Pitch -> Pitch
PSignal.drop_discontinuity_at RealTime
end (Pitch -> Pitch) -> PitchMap -> PitchMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Dynamic -> PitchMap
Derive.state_pitches Dynamic
dyn
    }

d_block :: BlockId -> Derive.NoteDeriver
d_block :: BlockId -> NoteDeriver
d_block BlockId
block_id = do
    Map BlockId Block
blocks <- (State -> Map BlockId Block) -> Deriver (Map BlockId Block)
forall a. (State -> a) -> Deriver a
Derive.get_ui_state State -> Map BlockId Block
Ui.state_blocks
    -- Do some error checking.  These are all caught later, but if I throw here
    -- I can give more specific error msgs.
    Text
title <- case BlockId -> Map BlockId Block -> Maybe Block
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId Block
blocks of
        Maybe Block
Nothing -> Text -> Deriver State Error Text
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"block_id not found"
        Just Block
block -> Text -> Deriver State Error Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Deriver State Error Text)
-> Text -> Deriver State Error Text
forall a b. (a -> b) -> a -> b
$ Block -> Text
Block.block_title Block
block
    -- Record a dependency on this block.  This should happen even if the
    -- derivation throws, because a dependency on a block with an error is
    -- still a dependency.
    BlockId -> Deriver State Error ()
Internal.add_block_dep BlockId
block_id
    let deriver :: NoteDeriver
deriver = BlockId -> NoteDeriver
BlockUtil.note_deriver BlockId
block_id
    (Maybe (Stream Note) -> Stream Note)
-> Deriver State Error (Maybe (Stream Note)) -> NoteDeriver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Stream Note -> Maybe (Stream Note) -> Stream Note
forall a. a -> Maybe a -> a
fromMaybe Stream Note
forall a. Stream a
Stream.empty) (Deriver State Error (Maybe (Stream Note)) -> NoteDeriver)
-> Deriver State Error (Maybe (Stream Note)) -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Bool -> NoteDeriver -> Deriver State Error (Maybe (Stream Note))
forall a. Bool -> Deriver a -> Deriver (Maybe a)
Derive.catch Bool
True (NoteDeriver -> Deriver State Error (Maybe (Stream Note)))
-> NoteDeriver -> Deriver State Error (Maybe (Stream Note))
forall a b. (a -> b) -> a -> b
$
        case Text -> Either Text Expr
ParseTitle.parse_block Text
title of
            Left Text
err -> Text -> NoteDeriver
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> NoteDeriver) -> Text -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Text
"block title: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
            -- An empty title means no transformation.
            Right (Expr.Call Symbol
call [] :| []) | Symbol
call Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol
"" -> NoteDeriver
deriver
            Right Expr
expr ->
                Context Note -> [Call] -> NoteDeriver -> NoteDeriver
forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> [Call] -> Deriver (Stream d) -> Deriver (Stream d)
Eval.eval_transformers Context Note
forall {a}. Context a
ctx (Expr -> [Call]
forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
expr) NoteDeriver
deriver
                where ctx :: Context a
ctx = ScoreTime -> ScoreTime -> Text -> Context a
forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
0 ScoreTime
1 Text
"block title"

-- | Given a block id, produce a call expression that will call that block.
call_from_block_id :: BlockId -> DeriveT.Call
call_from_block_id :: BlockId -> Call
call_from_block_id BlockId
block_id =
    Symbol -> Call
forall val. Symbol -> Call val
Expr.call0 (Text -> Symbol
Expr.Symbol (Text -> Symbol) -> Text -> Symbol
forall a b. (a -> b) -> a -> b
$ Id -> Text
Id.show_id (Id -> Text) -> Id -> Text
forall a b. (a -> b) -> a -> b
$ BlockId -> Id
forall a. Ident a => a -> Id
Id.unpack_id BlockId
block_id)

-- | Like 'Eval.call_to_block_id' but make sure the block exists.
call_to_block_id :: Expr.Symbol -> Derive.Deriver (Maybe BlockId)
call_to_block_id :: Symbol -> Deriver State Error (Maybe BlockId)
call_to_block_id Symbol
sym = do
    Maybe BlockId
caller <- Deriver State Error (Maybe BlockId)
Internal.lookup_current_block_id
    Namespace
ns <- (State -> Namespace) -> Deriver Namespace
forall a. (State -> a) -> Deriver a
Derive.get_ui_state ((State -> Namespace) -> Deriver Namespace)
-> (State -> Namespace) -> Deriver Namespace
forall a b. (a -> b) -> a -> b
$ Config -> Namespace
UiConfig.config_namespace (Config -> Namespace) -> (State -> Config) -> State -> Namespace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Ui.state_config
    case Namespace -> Maybe BlockId -> Symbol -> Maybe BlockId
Eval.call_to_block_id Namespace
ns Maybe BlockId
caller Symbol
sym of
        Maybe BlockId
Nothing -> Maybe BlockId -> Deriver State Error (Maybe BlockId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BlockId
forall a. Maybe a
Nothing
        Just BlockId
block_id -> do
            Map BlockId Block
blocks <- (State -> Map BlockId Block) -> Deriver (Map BlockId Block)
forall a. (State -> a) -> Deriver a
Derive.get_ui_state State -> Map BlockId Block
Ui.state_blocks
            Maybe BlockId -> Deriver State Error (Maybe BlockId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe BlockId -> Deriver State Error (Maybe BlockId))
-> Maybe BlockId -> Deriver State Error (Maybe BlockId)
forall a b. (a -> b) -> a -> b
$ if BlockId -> Map BlockId Block -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member BlockId
block_id Map BlockId Block
blocks then BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
block_id
                else Maybe BlockId
forall a. Maybe a
Nothing

-- * control calls

pattern_control_block :: Derive.PatternCall (Derive.Generator Derive.Control)
pattern_control_block :: PatternCall (Generator Control)
pattern_control_block = Derive.PatternCall
    { pat_description :: Text
pat_description = Text
"block name"
    , pat_doc :: DocumentedCall
pat_doc = Generator Control -> DocumentedCall
forall d. Call d -> DocumentedCall
Derive.extract_doc Generator Control
fake_call
    , pat_function :: Symbol -> Deriver (Maybe (Generator Control))
pat_function = \Symbol
sym -> (BlockId -> Generator Control)
-> Maybe BlockId -> Maybe (Generator Control)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockId -> Generator Control
c_control_block (Maybe BlockId -> Maybe (Generator Control))
-> Deriver State Error (Maybe BlockId)
-> Deriver (Maybe (Generator Control))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbol -> Deriver State Error (Maybe BlockId)
call_to_block_id Symbol
sym
    }
    where
    -- Not evaluated, so it doesn't matter if the BlockId is invalid.
    fake_call :: Generator Control
fake_call = BlockId -> Generator Control
c_control_block (Id -> BlockId
Id.BlockId (Text -> Id
Id.read_id Text
"example/block"))

c_control_block :: BlockId -> Derive.Generator Derive.Control
c_control_block :: BlockId -> Generator Control
c_control_block BlockId
block_id = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Control)
-> Generator Control
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"control-block"
    Tags
forall a. Monoid a => a
mempty (Doc
"Substitute the control signal from the named control block.\
    \ A control block should consist of a single branch ending in\
    \ a track named `%`.  The signal from that track will be\
    \ substituted."
    ) (WithArgDoc (GeneratorF Control) -> Generator Control)
-> WithArgDoc (GeneratorF Control) -> Generator Control
forall a b. (a -> b) -> a -> b
$
    GeneratorF Control -> WithArgDoc (GeneratorF Control)
forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 (GeneratorF Control -> WithArgDoc (GeneratorF Control))
-> GeneratorF Control -> WithArgDoc (GeneratorF Control)
forall a b. (a -> b) -> a -> b
$ \PassedArgs Control
args -> do
        let (ScoreTime
start, ScoreTime
end) = PassedArgs Control -> (ScoreTime, ScoreTime)
forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Control
args
        ScoreTime
-> ScoreTime
-> Deriver (Stream Control)
-> Deriver (Stream Control)
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start (ScoreTime
endScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
-ScoreTime
start) (BlockId -> Deriver (Stream Control)
d_control_block BlockId
block_id)

d_control_block :: BlockId -> Derive.ControlDeriver
d_control_block :: BlockId -> Deriver (Stream Control)
d_control_block BlockId
block_id = BlockId -> Deriver (Stream Control) -> Deriver (Stream Control)
forall a. BlockId -> Deriver a -> Deriver a
Internal.with_stack_block BlockId
block_id (Deriver (Stream Control) -> Deriver (Stream Control))
-> Deriver (Stream Control) -> Deriver (Stream Control)
forall a b. (a -> b) -> a -> b
$ do
    -- Control calls aren't cached, so I can put the block stack in the
    -- convenient place.
    Map BlockId Block
blocks <- (State -> Map BlockId Block) -> Deriver (Map BlockId Block)
forall a. (State -> a) -> Deriver a
Derive.get_ui_state State -> Map BlockId Block
Ui.state_blocks
    Bool -> Deriver State Error () -> Deriver State Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockId -> Map BlockId Block -> Maybe Block
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId Block
blocks Maybe Block -> Maybe Block -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Block
forall a. Maybe a
Nothing) (Deriver State Error () -> Deriver State Error ())
-> Deriver State Error () -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$
        Text -> Deriver State Error ()
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"block_id not found"
    BlockId -> Deriver State Error ()
Internal.add_block_dep BlockId
block_id
    Deriver (Stream Control)
deriver <- StateId (Deriver (Stream Control))
-> Deriver (Deriver (Stream Control))
forall a. HasCallStack => StateId a -> Deriver a
Derive.eval_ui (StateId (Deriver (Stream Control))
 -> Deriver (Deriver (Stream Control)))
-> StateId (Deriver (Stream Control))
-> Deriver (Deriver (Stream Control))
forall a b. (a -> b) -> a -> b
$ BlockId -> StateId (Deriver (Stream Control))
BlockUtil.control_deriver BlockId
block_id
    Deriver (Stream Control)
deriver

c_capture_null_control :: Derive.Generator Derive.Note
c_capture_null_control :: Generator Note
c_capture_null_control = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Note -> Deriver Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.internal
    (Symbol -> CallName
Derive.sym_to_call_name Symbol
BlockUtil.capture_null_control) Tags
forall a. Monoid a => a
mempty
    (Doc
"This is an internal call used to capture the control signal at the\
    \ bottom of a control block."
    ) (WithArgDoc (PassedArgs Note -> Deriver Note) -> Generator Note)
-> WithArgDoc (PassedArgs Note -> Deriver Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ (PassedArgs Note -> Deriver Note)
-> WithArgDoc (PassedArgs Note -> Deriver Note)
forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 ((PassedArgs Note -> Deriver Note)
 -> WithArgDoc (PassedArgs Note -> Deriver Note))
-> (PassedArgs Note -> Deriver Note)
-> WithArgDoc (PassedArgs Note -> Deriver Note)
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_ -> do
        Typed Control
sig <- Text -> Maybe (Typed Control) -> Deriver (Typed Control)
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"no null control to capture"
            (Maybe (Typed Control) -> Deriver (Typed Control))
-> Deriver State Error (Maybe (Typed Control))
-> Deriver (Typed Control)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Control -> Deriver State Error (Maybe (Typed Control))
Derive.lookup_control_signal Control
Controls.null
        Stack
stack <- Deriver Stack
Derive.get_stack
        Note -> Deriver Note
forall (m :: * -> *) a. Monad m => a -> m a
return (Note -> Deriver Note) -> Note -> Deriver Note
forall a b. (a -> b) -> a -> b
$! Control -> Typed Control -> Note -> Note
Score.set_control Control
Controls.null Typed Control
sig Note
Score.empty_event
            { event_stack :: Stack
Score.event_stack = Stack
stack }