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

{-# LANGUAGE CPP #-}
{- | Utilities for "Derive.Call.Block".

    Derivation of a block is much more complicated than it might first appear.
    This can cause score code to be evaluated more times than you think it
    should be.

    One culprit is evaluating tracks for control signals for signal render.
    Under some circumstances, the track's normal control output can be directly
    reused as the signal render, but in many cases it has to be evaluated
    again.  This is further complicated by the presence of inversion and
    orphans.
-}
module Derive.Call.BlockUtil (
    note_deriver, control_deriver
    , capture_null_control
    , derive_tracks
    , has_top_tempo_track

#ifdef TESTING
    , derive_tree
#endif
) where
import qualified Data.Tree as Tree

import qualified Util.Log as Log
import qualified Util.Seq as Seq
import qualified Util.Trees as Trees

import qualified Derive.Cache as Cache
import qualified Derive.Control as Control
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.EnvKey as EnvKey
import qualified Derive.EvalTrack as EvalTrack
import qualified Derive.Expr as Expr
import qualified Derive.LEvent as LEvent
import qualified Derive.Note as Note
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.Tempo as Tempo

import qualified Perform.Signal as Signal
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


note_deriver :: BlockId -> Derive.NoteDeriver
note_deriver :: BlockId -> NoteDeriver
note_deriver BlockId
block_id = do
    (EventsTree
tree, (TrackTime, TrackTime)
block_range) <- StateId (EventsTree, (TrackTime, TrackTime))
-> Deriver (EventsTree, (TrackTime, TrackTime))
forall a. HasCallStack => StateId a -> Deriver a
Derive.eval_ui (StateId (EventsTree, (TrackTime, TrackTime))
 -> Deriver (EventsTree, (TrackTime, TrackTime)))
-> StateId (EventsTree, (TrackTime, TrackTime))
-> Deriver (EventsTree, (TrackTime, TrackTime))
forall a b. (a -> b) -> a -> b
$
        (,) (EventsTree
 -> (TrackTime, TrackTime) -> (EventsTree, (TrackTime, TrackTime)))
-> StateT Identity EventsTree
-> StateT
     Identity
     ((TrackTime, TrackTime) -> (EventsTree, (TrackTime, TrackTime)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> StateT Identity EventsTree
forall (m :: * -> *). M m => BlockId -> m EventsTree
TrackTree.block_events_tree BlockId
block_id
            StateT
  Identity
  ((TrackTime, TrackTime) -> (EventsTree, (TrackTime, TrackTime)))
-> StateT Identity (TrackTime, TrackTime)
-> StateId (EventsTree, (TrackTime, TrackTime))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockId -> StateT Identity (TrackTime, TrackTime)
forall (m :: * -> *). M m => BlockId -> m (TrackTime, TrackTime)
Ui.block_logical_range BlockId
block_id
    TrackTime -> NoteDeriver -> NoteDeriver
forall a. TrackTime -> Deriver a -> Deriver a
with_per_block_state ((TrackTime, TrackTime) -> TrackTime
forall a b. (a, b) -> b
snd (TrackTime, TrackTime)
block_range) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ (TrackTime, TrackTime) -> EventsTree -> NoteDeriver
derive_tree (TrackTime, TrackTime)
block_range EventsTree
tree

-- | Reset Dynamic state for a new block.
with_per_block_state :: TrackTime -> Derive.Deriver a -> Derive.Deriver a
with_per_block_state :: forall a. TrackTime -> Deriver a -> Deriver a
with_per_block_state TrackTime
end = Deriver a -> Deriver a
forall {a}. Deriver a -> Deriver a
clear (Deriver a -> Deriver a)
-> (Deriver a -> Deriver a) -> Deriver a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TrackTime -> Deriver a -> Deriver a
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
EnvKey.block_end TrackTime
end
    where
    clear :: Deriver a -> Deriver a
clear = (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
state -> Dynamic
state
        { state_note_track :: Maybe (BlockId, TrackId)
Derive.state_note_track = Maybe (BlockId, TrackId)
forall a. Maybe a
Nothing
        , state_pitch_map :: Maybe (Maybe PSignal, [Msg])
Derive.state_pitch_map = Maybe (Maybe PSignal, [Msg])
forall a. Maybe a
Nothing -- set by 'with_pitch_map' below
        }

-- * control deriver

-- | Control blocks are very restricted: they should consist of a single
-- branch ending in a track with a @%@ title, which is the default control,
-- which should have been set by the calling track.  If the requirements are
-- met, a fake note track will be appended to make this a valid note block,
-- with a single note event whose only job is to collect the the default
-- control.
control_deriver :: BlockId -> Ui.StateId Derive.ControlDeriver
control_deriver :: BlockId -> StateId ControlDeriver
control_deriver BlockId
block_id = do
    EventsTree
tree <- BlockId -> StateT Identity EventsTree
forall (m :: * -> *). M m => BlockId -> m EventsTree
TrackTree.block_events_tree BlockId
block_id
    (TrackTime, TrackTime)
block_range <- BlockId -> StateT Identity (TrackTime, TrackTime)
forall (m :: * -> *). M m => BlockId -> m (TrackTime, TrackTime)
Ui.block_logical_range BlockId
block_id
    case TrackTime -> EventsTree -> Either Text EventsTree
check_control_tree ((TrackTime, TrackTime) -> TrackTime
forall a b. (a, b) -> b
snd (TrackTime, TrackTime)
block_range) EventsTree
tree of
        Left Text
err -> Text -> StateId ControlDeriver
forall (m :: * -> *) a. (HasCallStack, M m) => Text -> m a
Ui.throw (Text -> StateId ControlDeriver) -> Text -> StateId ControlDeriver
forall a b. (a -> b) -> a -> b
$ Text
"control block skeleton malformed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
        Right EventsTree
tree -> ControlDeriver -> StateId ControlDeriver
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlDeriver -> StateId ControlDeriver)
-> ControlDeriver -> StateId ControlDeriver
forall a b. (a -> b) -> a -> b
$ TrackTime -> ControlDeriver -> ControlDeriver
forall a. TrackTime -> Deriver a -> Deriver a
with_per_block_state ((TrackTime, TrackTime) -> TrackTime
forall a b. (a, b) -> b
snd (TrackTime, TrackTime)
block_range) (ControlDeriver -> ControlDeriver)
-> ControlDeriver -> ControlDeriver
forall a b. (a -> b) -> a -> b
$
            (TrackTime, TrackTime) -> EventsTree -> ControlDeriver
derive_control_tree (TrackTime, TrackTime)
block_range EventsTree
tree

-- | Name of the call for the control deriver hack.
capture_null_control :: Expr.Symbol
capture_null_control :: Symbol
capture_null_control = Symbol
"capture-null-control"

-- | Ensure the tree meets the requirements documented by 'control_deriver'
-- and append the fake note track if it does.
check_control_tree :: ScoreTime -> TrackTree.EventsTree
    -> Either Text TrackTree.EventsTree
check_control_tree :: TrackTime -> EventsTree -> Either Text EventsTree
check_control_tree TrackTime
block_end EventsTree
forest = case EventsTree
forest of
    [] -> Text -> Either Text EventsTree
forall a b. a -> Either a b
Left Text
"empty block"
    [Tree.Node Track
track []]
        | Track -> Text
TrackTree.track_title Track
track Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"%" ->
            EventsTree -> Either Text EventsTree
forall a b. b -> Either a b
Right [Track -> EventsTree -> Tree Track
forall a. a -> [Tree a] -> Tree a
Tree.Node Track
track [Track -> EventsTree -> Tree Track
forall a. a -> [Tree a] -> Tree a
Tree.Node Track
capture_track []]]
        | Bool
otherwise -> Text -> Either Text EventsTree
forall a b. a -> Either a b
Left (Text -> Either Text EventsTree) -> Text -> Either Text EventsTree
forall a b. (a -> b) -> a -> b
$ Text
"skeleton must end in % track, ends with "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showt (Track -> Text
TrackTree.track_title Track
track)
    [Tree.Node Track
track EventsTree
subs] -> do
        EventsTree
subs <- TrackTime -> EventsTree -> Either Text EventsTree
check_control_tree TrackTime
block_end EventsTree
subs
        EventsTree -> Either Text EventsTree
forall (m :: * -> *) a. Monad m => a -> m a
return [Track -> EventsTree -> Tree Track
forall a. a -> [Tree a] -> Tree a
Tree.Node Track
track EventsTree
subs]
    EventsTree
tracks -> Text -> Either Text EventsTree
forall a b. a -> Either a b
Left (Text -> Either Text EventsTree) -> Text -> Either Text EventsTree
forall a b. (a -> b) -> a -> b
$ Text
"skeleton must have only a single branch, "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"but there are multiple children: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
showt ((Tree Track -> Text) -> EventsTree -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Track -> Text
TrackTree.track_title (Track -> Text) -> (Tree Track -> Track) -> Tree Track -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Track -> Track
forall a. Tree a -> a
Tree.rootLabel) EventsTree
tracks)
    where
    events :: Events
events = Event -> Events
Events.singleton (Event -> Events) -> Event -> Events
forall a b. (a -> b) -> a -> b
$
        TrackTime -> TrackTime -> Text -> Event
Event.event TrackTime
0 TrackTime
block_end (Symbol -> Text
Expr.unsym Symbol
capture_null_control)
    capture_track :: Track
capture_track = Text -> Events -> TrackTime -> Track
TrackTree.make_track Text
">" Events
events TrackTime
block_end

derive_control_tree :: (ScoreTime, ScoreTime) -> TrackTree.EventsTree
    -> Derive.ControlDeriver
derive_control_tree :: (TrackTime, TrackTime) -> EventsTree -> ControlDeriver
derive_control_tree (TrackTime, TrackTime)
block_range EventsTree
tree = do
    -- There are an awful lot of things that can go wrong.  I guess that's why
    -- this is a hack.
    Stream Event
events <- (TrackTime, TrackTime) -> EventsTree -> NoteDeriver
derive_tree (TrackTime, TrackTime)
block_range EventsTree
tree
    case Stream Event -> ([Event], [Msg])
forall a. Stream a -> ([a], [Msg])
Stream.partition Stream Event
events of
        ([Event
event], [Msg]
logs) -> case Control -> Event -> Maybe (Typed Control)
Score.event_control Control
Controls.null Event
event of
            Maybe (Typed Control)
Nothing -> Text -> ControlDeriver
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"control call didn't emit Controls.null"
            Just Typed Control
signal -> Stream Control -> ControlDeriver
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream Control -> ControlDeriver)
-> Stream Control -> ControlDeriver
forall a b. (a -> b) -> a -> b
$ [LEvent Control] -> Stream Control
forall a. [LEvent a] -> Stream a
Stream.from_sorted_list ([LEvent Control] -> Stream Control)
-> [LEvent Control] -> Stream Control
forall a b. (a -> b) -> a -> b
$
                -- The calling control itself will be providing the type since
                -- types are at the level of the signal as a whole.
                Control -> LEvent Control
forall a. a -> LEvent a
LEvent.Event (Typed Control -> Control
forall a. Typed a -> a
ScoreT.typed_val Typed Control
signal) LEvent Control -> [LEvent Control] -> [LEvent Control]
forall a. a -> [a] -> [a]
: (Msg -> LEvent Control) -> [Msg] -> [LEvent Control]
forall a b. (a -> b) -> [a] -> [b]
map Msg -> LEvent Control
forall a. Msg -> LEvent a
LEvent.Log [Msg]
logs
        ([Event]
events, [Msg]
logs) -> do
            Msg
msg <- [Event] -> Deriver Msg
forall {a}. Show a => a -> Deriver Msg
complain [Event]
events
            Stream Control -> ControlDeriver
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream Control -> ControlDeriver)
-> Stream Control -> ControlDeriver
forall a b. (a -> b) -> a -> b
$ [Msg] -> Stream Control
forall a. [Msg] -> Stream a
Stream.from_logs ([Msg] -> Stream Control) -> [Msg] -> Stream Control
forall a b. (a -> b) -> a -> b
$ Msg
msg Msg -> [Msg] -> [Msg]
forall a. a -> [a] -> [a]
: [Msg]
logs
    where
    -- Or I could throw, but this way any other logs the block emitted will
    -- also be visible, and they might have something interesting.
    complain :: a -> Deriver Msg
complain a
events = Msg -> Deriver Msg
Derive.initialize_log_msg (Msg -> Deriver Msg) -> Msg -> Deriver Msg
forall a b. (a -> b) -> a -> b
$ HasCallStack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn Maybe Stack
forall a. Maybe a
Nothing (Text -> Msg) -> Text -> Msg
forall a b. (a -> b) -> a -> b
$
        Text
"control call should have emitted a single call to "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Symbol -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Symbol
capture_null_control
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" which produces a single event, but got events: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
events

-- ** implementation

derive_tree :: (ScoreTime, ScoreTime) -> TrackTree.EventsTree
    -> Derive.NoteDeriver
derive_tree :: (TrackTime, TrackTime) -> EventsTree -> NoteDeriver
derive_tree (TrackTime, TrackTime)
block_range EventsTree
tree
    | Just Tree Track
node <- EventsTree -> Maybe (Tree Track)
has_top_tempo_track EventsTree
tree = Bool -> Tree Track -> NoteDeriver
derive_track Bool
True Tree Track
node
    | Bool
otherwise = do
        -- Every block must have a tempo track as the topmost track.  This is
        -- because Tempo.with_tempo sets up some stuff that every block needs,
        -- and because I need a TrackWarp for the tracks below.
        Y
tempo <- Deriver State Error Y
get_tempo
        Bool
-> Maybe (TrackTime, TrackTime)
-> Maybe TrackId
-> Tempo
-> NoteDeriver
-> NoteDeriver
forall a.
Monoid a =>
Bool
-> Maybe (TrackTime, TrackTime)
-> Maybe TrackId
-> Tempo
-> Deriver a
-> Deriver a
Tempo.with_tempo Bool
True ((TrackTime, TrackTime) -> Maybe (TrackTime, TrackTime)
forall a. a -> Maybe a
Just (TrackTime, TrackTime)
block_range) Maybe TrackId
forall a. Maybe a
Nothing (Y -> Tempo
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
tempo)
            (EventsTree -> NoteDeriver
derive_tracks EventsTree
tree)
    where
    get_tempo :: Deriver State Error Y
get_tempo = Text -> Deriver (Maybe Y)
forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.tempo Deriver (Maybe Y)
-> (Maybe Y -> Deriver State Error Y) -> Deriver State Error Y
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Y
Nothing -> (Config -> Y) -> Deriver State Error Y
forall a. (Config -> a) -> Deriver a
Derive.get_ui_config ((Config -> Y) -> Deriver State Error Y)
-> (Config -> Y) -> Deriver State Error Y
forall a b. (a -> b) -> a -> b
$
            Default -> Y
UiConfig.default_tempo (Default -> Y) -> (Config -> Default) -> Config -> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Default
UiConfig.config_default
        Just Y
tempo -> Y -> Deriver State Error Y
forall (m :: * -> *) a. Monad m => a -> m a
return Y
tempo

-- | Derive an EventsTree.
derive_tracks :: TrackTree.EventsTree -> Derive.NoteDeriver
derive_tracks :: EventsTree -> NoteDeriver
derive_tracks = (Tree Track -> NoteDeriver) -> EventsTree -> NoteDeriver
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (Bool -> Tree Track -> NoteDeriver
derive_track Bool
False)

-- | Derive a single track node and any tracks below it.
derive_track :: Bool -- ^ True if this is the single topmost track and is
    -- a tempo track.  Ultimately this flag gets threaded all the way down to
    -- "Derive.Tempo".
    -> TrackTree.EventsNode -> Derive.NoteDeriver
derive_track :: Bool -> Tree Track -> NoteDeriver
derive_track Bool
toplevel node :: Tree Track
node@(Tree.Node Track
track EventsTree
subs)
    | Text -> Bool
ParseTitle.is_note_track (Track -> Text
TrackTree.track_title Track
track) =
        NoteDeriver -> NoteDeriver
forall {a}. Deriver a -> Deriver a
with_stack (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Track -> Set TrackId -> NoteDeriver -> NoteDeriver
forall d.
Cacheable d =>
Track -> Set TrackId -> Deriver (Stream d) -> Deriver (Stream d)
Cache.track Track
track (Tree Track -> Set TrackId
TrackTree.track_children Tree Track
node) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ do
            Stream Event
events <- Track -> NoteDeriver -> NoteDeriver
forall {a}. Track -> Deriver a -> Deriver a
with_voice Track
track (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Track -> EventsTree -> NoteDeriver -> NoteDeriver
forall a. Track -> EventsTree -> Deriver a -> Deriver a
with_pitch_map Track
track EventsTree
subs (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
                (NoteDeriver -> NoteDeriver)
-> (TrackId -> NoteDeriver -> NoteDeriver)
-> Maybe TrackId
-> NoteDeriver
-> NoteDeriver
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NoteDeriver -> NoteDeriver
forall a. a -> a
id TrackId -> NoteDeriver -> NoteDeriver
forall a. TrackId -> Deriver a -> Deriver a
with_note_track (Track -> Maybe TrackId
TrackTree.track_id Track
track) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
                (EventsTree -> NoteDeriver) -> Tree Track -> NoteDeriver
Note.d_note_track EventsTree -> NoteDeriver
derive_tracks Tree Track
node
            Bool -> Deriver State Error () -> Deriver State Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Track -> Sliced
TrackTree.track_sliced Track
track Sliced -> Sliced -> Bool
forall a. Eq a => a -> a -> Bool
== Sliced
TrackTree.NotSliced)
                Deriver State Error ()
defragment
            (Track -> Deriver State Error ())
-> [Track] -> Deriver State Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Stream Event -> Track -> Deriver State Error ()
Note.stash_signal_if_wanted Stream Event
events)
                (Track -> EventsTree -> [Track]
note_signal_tracks Track
track EventsTree
subs)
            Stream Event -> NoteDeriver
forall (m :: * -> *) a. Monad m => a -> m a
return Stream Event
events
    | Bool
otherwise = NoteDeriver -> NoteDeriver
forall {a}. Deriver a -> Deriver a
with_stack (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
        Config -> Track -> NoteDeriver -> NoteDeriver
Control.d_control_track (Bool -> Bool -> Config
Control.Config Bool
toplevel Bool
True) Track
track
            (EventsTree -> NoteDeriver
derive_tracks EventsTree
subs)
    where
    with_voice :: Track -> Deriver a -> Deriver a
with_voice = (Deriver a -> Deriver a)
-> (Int -> Deriver a -> Deriver a)
-> Maybe Int
-> Deriver a
-> Deriver a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Deriver a -> Deriver a
forall a. a -> a
id (Text -> Int -> Deriver a -> Deriver a
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
EnvKey.track_voice)
        (Maybe Int -> Deriver a -> Deriver a)
-> (Track -> Maybe Int) -> Track -> Deriver a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Maybe Int
TrackTree.track_voice
    defragment :: Deriver State Error ()
defragment = do
        Warp
warp <- Deriver Warp
Internal.get_warp
        (Collect -> Collect) -> Deriver State Error ()
Internal.modify_collect ((Collect -> Collect) -> Deriver State Error ())
-> (Collect -> Collect) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Warp -> Collect -> Collect
EvalTrack.defragment_track_signals Warp
warp
    with_stack :: Deriver a -> Deriver a
with_stack = (Deriver a -> Deriver a)
-> (TrackId -> Deriver a -> Deriver a)
-> Maybe TrackId
-> Deriver a
-> Deriver a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Deriver a -> Deriver a
forall a. a -> a
id TrackId -> Deriver a -> Deriver a
forall a. TrackId -> Deriver a -> Deriver a
Internal.with_stack_track (Track -> Maybe TrackId
TrackTree.track_id Track
track)

with_note_track :: TrackId -> Derive.Deriver a -> Derive.Deriver a
with_note_track :: forall a. TrackId -> Deriver a -> Deriver a
with_note_track TrackId
track_id Deriver a
deriver = do
    Maybe BlockId
maybe_block_id <- [Maybe BlockId] -> Maybe BlockId
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe BlockId] -> Maybe BlockId)
-> (Stack -> [Maybe BlockId]) -> Stack -> Maybe BlockId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Frame -> Maybe BlockId) -> [Frame] -> [Maybe BlockId]
forall a b. (a -> b) -> [a] -> [b]
map Frame -> Maybe BlockId
Stack.block_of ([Frame] -> [Maybe BlockId])
-> (Stack -> [Frame]) -> Stack -> [Maybe BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
Stack.innermost (Stack -> Maybe BlockId)
-> Deriver State Error Stack -> Deriver State Error (Maybe BlockId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Deriver State Error Stack
Internal.get_stack
    (Deriver a -> Deriver a)
-> (BlockId -> Deriver a -> Deriver a)
-> Maybe BlockId
-> Deriver a
-> Deriver a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Deriver a -> Deriver a
forall a. a -> a
id BlockId -> Deriver a -> Deriver a
forall {a}. BlockId -> Deriver a -> Deriver a
with Maybe BlockId
maybe_block_id Deriver a
deriver
    where
    with :: BlockId -> Deriver a -> Deriver a
with BlockId
block_id = (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
state -> Dynamic
state
        { state_note_track :: Maybe (BlockId, TrackId)
Derive.state_note_track = (BlockId, TrackId) -> Maybe (BlockId, TrackId)
forall a. a -> Maybe a
Just (BlockId
block_id, TrackId
track_id) }

-- | Extract tracks that might want to stash a signal.
--
-- A note track can display a signal, extracted from the events it generates.
-- But if the track has orphan sub-tracks, its events will be evaluated
-- separately, either directly as orphans, or indirectly as the children of the
-- non-orphan sections.  At the moment it seems simpler to collect all the
-- events of the whole set of tracks and consider them the output of all of
-- them.
note_signal_tracks :: TrackTree.Track -> TrackTree.EventsTree
    -> [TrackTree.Track]
note_signal_tracks :: Track -> EventsTree -> [Track]
note_signal_tracks Track
track EventsTree
subs = case Track -> Sliced
TrackTree.track_sliced Track
track of
    Sliced
TrackTree.NotSliced -> Track
track Track -> [Track] -> [Track]
forall a. a -> [a] -> [a]
: (Track -> Bool) -> [Track] -> [Track]
forall a. (a -> Bool) -> [a] -> [a]
filter Track -> Bool
is_note ((Tree Track -> [Track]) -> EventsTree -> [Track]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Track -> [Track]
forall a. Tree a -> [a]
Tree.flatten EventsTree
subs)
    Sliced
_ -> []
    where is_note :: Track -> Bool
is_note = Text -> Bool
ParseTitle.is_note_track (Text -> Bool) -> (Track -> Text) -> Track -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Text
TrackTree.track_title

-- | The tempo track, if the top level track is a tempo track.
has_top_tempo_track :: [Tree.Tree TrackTree.Track]
    -> Maybe (Tree.Tree TrackTree.Track)
has_top_tempo_track :: EventsTree -> Maybe (Tree Track)
has_top_tempo_track EventsTree
tree = case EventsTree
tree of
    [node :: Tree Track
node@(Tree.Node Track
track EventsTree
_)] | Track -> Bool
is_tempo Track
track -> Tree Track -> Maybe (Tree Track)
forall a. a -> Maybe a
Just Tree Track
node
    EventsTree
_ -> Maybe (Tree Track)
forall a. Maybe a
Nothing
    where
    is_tempo :: Track -> Bool
is_tempo = Text -> Bool
ParseTitle.is_tempo_track (Text -> Bool) -> (Track -> Text) -> Track -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Text
TrackTree.track_title

-- * track pitch map

-- | Given an event track, look for a pitch track below it, and derive it
-- standalone.  If there is none, then take 'Derive.state_pitch'.  Put this
-- into 'Derive.state_pitch_map'.
with_pitch_map :: TrackTree.Track -> TrackTree.EventsTree -> Derive.Deriver a
    -> Derive.Deriver a
with_pitch_map :: forall a. Track -> EventsTree -> Deriver a -> Deriver a
with_pitch_map Track
track EventsTree
subs Deriver a
deriver = case Track -> Sliced
TrackTree.track_sliced Track
track of
    Sliced
TrackTree.NotSliced -> do
        (Maybe PSignal, [Msg])
pmap <- EventsTree -> Deriver (Maybe PSignal, [Msg])
get_pitch_map EventsTree
subs
        (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local (\Dynamic
state -> Dynamic
state { state_pitch_map :: Maybe (Maybe PSignal, [Msg])
Derive.state_pitch_map = (Maybe PSignal, [Msg]) -> Maybe (Maybe PSignal, [Msg])
forall a. a -> Maybe a
Just (Maybe PSignal, [Msg])
pmap })
            Deriver a
deriver
    Sliced
_ -> Deriver a
deriver

get_pitch_map :: TrackTree.EventsTree
    -> Derive.Deriver (Maybe PSignal.PSignal, [Log.Msg])
get_pitch_map :: EventsTree -> Deriver (Maybe PSignal, [Msg])
get_pitch_map EventsTree
subs = case EventsTree -> Maybe Track
pitch_map_track EventsTree
subs of
    Just Track
pitch_track -> do
        State
state <- Deriver State Error State
forall st err. Deriver st err st
Derive.get
        (Maybe PSignal, [Msg]) -> Deriver (Maybe PSignal, [Msg])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe PSignal, [Msg]) -> Deriver (Maybe PSignal, [Msg]))
-> (Maybe PSignal, [Msg]) -> Deriver (Maybe PSignal, [Msg])
forall a b. (a -> b) -> a -> b
$ State -> Track -> (Maybe PSignal, [Msg])
derive_pitch_map State
state Track
pitch_track
    Maybe Track
Nothing -> do
        PSignal
sig <- (Dynamic -> PSignal) -> Deriver PSignal
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> PSignal
Derive.state_pitch
        (Maybe PSignal, [Msg]) -> Deriver (Maybe PSignal, [Msg])
forall (m :: * -> *) a. Monad m => a -> m a
return (PSignal -> Maybe PSignal
forall a. a -> Maybe a
Just PSignal
sig, [])

-- | Derive the given pitch track lazily.
--
-- It uses a hack similar to control blocks, e.g. 'derive_control_tree'.
derive_pitch_map :: Derive.State -> TrackTree.Track
    -> (Maybe PSignal.PSignal, [Log.Msg])
derive_pitch_map :: State -> Track -> (Maybe PSignal, [Msg])
derive_pitch_map State
state Track
pitch_track = case Either Error PSignal
result of
    Right PSignal
sig -> (PSignal -> Maybe PSignal
forall a. a -> Maybe a
Just PSignal
sig, [Msg]
logs)
    Left Error
err -> (Maybe PSignal
forall a. Maybe a
Nothing, Error -> Msg
Derive.error_to_warn Error
err Msg -> [Msg] -> [Msg]
forall a. a -> [a] -> [a]
: [Msg]
logs)
    where
    (Either Error PSignal
result, State
_, [Msg]
logs) = State -> Deriver PSignal -> (Either Error PSignal, State, [Msg])
forall st err a. st -> Deriver st err a -> RunResult st err a
Derive.run State
stripped (Track -> Deriver PSignal
derive Track
pitch_track)
    stripped :: State
stripped = State
state
        { state_dynamic :: Dynamic
Derive.state_dynamic = (State -> Dynamic
Derive.state_dynamic State
state)
            -- As documented by 'Derive.state_pitch_map'.
            { state_pitch_map :: Maybe (Maybe PSignal, [Msg])
Derive.state_pitch_map = Maybe (Maybe PSignal, [Msg])
forall a. Maybe a
Nothing }
        }
    derive :: Track -> Deriver PSignal
derive Track
pitch_track = do
        ([Event]
events, [Msg]
logs) <- Stream Event -> ([Event], [Msg])
forall a. Stream a -> ([a], [Msg])
Stream.partition (Stream Event -> ([Event], [Msg]))
-> NoteDeriver -> Deriver State Error ([Event], [Msg])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NoteDeriver -> NoteDeriver
forall {a}. Deriver a -> Deriver a
Internal.in_real_time
            (Config -> Track -> NoteDeriver -> NoteDeriver
Control.d_control_track Config
config Track
pitch_track NoteDeriver
capture)
        (Msg -> Deriver State Error ()) -> [Msg] -> Deriver State Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Msg -> Deriver State Error ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
        Text -> Maybe PSignal -> Deriver PSignal
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"get_pitch_map: no event" (Maybe PSignal -> Deriver PSignal)
-> Maybe PSignal -> Deriver PSignal
forall a b. (a -> b) -> a -> b
$
            Event -> PSignal
Score.event_pitch (Event -> PSignal) -> Maybe Event -> Maybe PSignal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head [Event]
events
    config :: Config
config = Control.Config
        { config_toplevel_tempo :: Bool
config_toplevel_tempo = Bool
False
        , config_use_cache :: Bool
config_use_cache = Bool
False
        }
    capture :: Derive.NoteDeriver
    capture :: NoteDeriver
capture = do
        PSignal
pitch <- (Dynamic -> PSignal) -> Deriver PSignal
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> PSignal
Derive.state_pitch
        Stream Event -> NoteDeriver
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream Event -> NoteDeriver) -> Stream Event -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Event -> Stream Event
forall a. a -> Stream a
Stream.from_event (Event -> Stream Event) -> Event -> Stream Event
forall a b. (a -> b) -> a -> b
$
            Event
Score.empty_event { event_pitch :: PSignal
Score.event_pitch = PSignal
pitch }

pitch_map_track :: TrackTree.EventsTree -> Maybe TrackTree.Track
pitch_map_track :: EventsTree -> Maybe Track
pitch_map_track = (Tree Track -> Track) -> Maybe (Tree Track) -> Maybe Track
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree Track -> Track
forall a. Tree a -> a
Tree.rootLabel (Maybe (Tree Track) -> Maybe Track)
-> (EventsTree -> Maybe (Tree Track)) -> EventsTree -> Maybe Track
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Track -> Bool) -> EventsTree -> Maybe (Tree Track)
forall a. (a -> Bool) -> [Tree a] -> Maybe (Tree a)
Trees.find Track -> Bool
is_pitch
    where is_pitch :: Track -> Bool
is_pitch = Text -> Bool
ParseTitle.is_pitch_track (Text -> Bool) -> (Track -> Text) -> Track -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Text
TrackTree.track_title