-- Copyright 2014 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 #-}
{-# LANGUAGE RankNTypes #-}
{- | Derive tracks.

    It should also have Deriver utilities that could go in Derive, but are more
    specific to calls.

    It used to be that events were evaluated in \"normalized time\", which to
    say each one was shifted and stretched into place so that it always
    begins at 0t and ends at 1t.  While elegant, this was awkward in
    practice.  Some calls take ScoreTimes as arguments, and for those to
    be in the track's ScoreTime they have to be warped too.  Calls that
    look at the time of the next event on the track must warp that too.
    The result is that calls have to work in two time references
    simultaneously, which is confusing.  But the main thing is that note
    calls with subtracks need to slice the relevant events out of the
    subtracks, and those events are naturally in track time.  So the slice
    times would have to be unwarped, and then the sliced events warped.
    It was too complicated.

    Now events are evaluated in track time.  Block calls still warp the
    call into place, so blocks are still in normalized time, but other
    calls must keep track of their start and end times.

    The way expression evaluation works is a little irregular.  The toplevel
    expression returns a parameterized deriver, so this part of the type is
    exported to the haskell type system.  The values and non-toplevel calls
    return dynamically typed Vals though.  The difference between a generator
    and a transformer is that the latter takes an extra deriver arg, but since
    the type of the deriver is statically determined at the haskell level, it
    isn't passed as a normal arg but is instead hardcoded into the evaluation
    scheme for the toplevel expression.  So only the toplevel calls can take
    and return derivers.

    I experimented with a system that added a VDeriver type, but there were
    several problems:

    - If I don't parameterize Val I wind up with separate VEventDeriver,
    VPitchDeriver, etc. constructors.  Every call that takes a deriver must
    validate the type and there is no static guarantee that event deriver
    calls won't wind up the pitch deriver symbol table.  It seems nice that
    the CallMap and Environ can all be replaced with a single symbol table,
    but in practice they represent different scopes, so they would need to be
    separated anyway.

    - If I do parameterize Val, I need some complicated typeclass gymnastics
    and a lot of redundant Typecheck instances to make the new VDeriver type
    fit in with the calling scheme.  I have to differentiate PassedVals, which
    include VDeriver, from Vals, which don't, so Environ can remain
    unparameterized.  Otherwise I would need a separate Environ per track, and
    copy over vals which should be shared, like srate.  The implication is
    that Environ should really have dynamically typed deriver vals.

    - Replacing @a | b | c@ with @a (b (c))@ is appealing, but if the deriver
    is the final argument then I have a problem where a required argument wants
    to follow an optional one.  Solutions would be to implement some kind of
    keyword args that allow the required arg to remain at the end, or simply
    put it as the first arg, so that @a 1 | b 2 | c 3@ is sugar for
    @a (b (c 3) 2) 1@.

    - But, most importantly, I don't have a clear use for making derivers first
    class.  Examples would be:

        * A call that takes two derivers: @do-something (block1) (block2)@.
        I can't think of a @do-something@.

        * Derivers in the environment: @default-something = (block1)@.  I
        can't think of a @default-something@.

    I could move more in the direction of a real language by unifying all
    symbols into Environ, looking up Symbols in @eval@, and making a VCall
    type.  That way I could rebind calls with @tr = absolute-trill@ or
    do argument substitution with @d = (block1); transpose 1 | d@.  However,
    I don't have any uses in mind for that, and /haskell/ is supposed to be
    the real language.  I should focus more on making it easy to write your own
    calls in haskell.
-}
module Derive.EvalTrack (
    TrackInfo(..)
    , GetLastVal
    , derive_control_track, derive_note_track
    , defragment_track_signals, unwarp
    , derive_event, context
#ifdef TESTING
    , module Derive.EvalTrack
#endif
) where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Pretty as Pretty

import qualified App.Config as Config
import qualified Derive.Derive as Derive
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.Parse as Parse
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Score as Score
import qualified Derive.Slice as Slice
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream
import qualified Derive.Warp as Warp

import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Track as Track
import qualified Ui.TrackTree as TrackTree

import           Global
import           Types


-- | Per-track parameters, to cut down on the number of arguments taken by
-- 'derive_note_track'.
data TrackInfo d = TrackInfo {
    forall d. TrackInfo d -> Track
tinfo_track :: !TrackTree.Track
    , forall d. TrackInfo d -> EventsTree
tinfo_sub_tracks :: !TrackTree.EventsTree
    , forall d. TrackInfo d -> Type
tinfo_type :: !ParseTitle.Type
    , forall d. TrackInfo d -> GetLastVal d
tinfo_get_last_val :: GetLastVal d
    }

tinfo_prev_val :: TrackInfo d -> Maybe d -> Stream.Stream d -> Maybe d
tinfo_prev_val :: forall d. TrackInfo d -> Maybe d -> Stream d -> Maybe d
tinfo_prev_val TrackInfo d
tinfo Maybe d
prev_val Stream d
levents =
    forall d. TrackInfo d -> GetLastVal d
tinfo_get_last_val TrackInfo d
tinfo (forall a. Stream a -> [a]
Stream.events_of Stream d
levents) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe d
prev_val

instance Pretty (TrackInfo d) where
    format :: TrackInfo d -> Doc
format (TrackInfo Track
track EventsTree
subs Type
ttype GetLastVal d
_) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"TrackInfo"
        [ (Text
"track", forall a. Pretty a => a -> Doc
Pretty.format Track
track)
        , (Text
"sub_tracks", forall a. Pretty a => a -> Doc
Pretty.format EventsTree
subs)
        , (Text
"type", forall a. Pretty a => a -> Doc
Pretty.format Type
ttype)
        ]

type GetLastVal d = [d] -> Maybe d
type DeriveResult d = ([Stream.Stream d], Derive.Threaded, Derive.Collect)

-- | This is the toplevel function to derive control tracks.  It's responsible
-- for actually evaluating each event.
{-# SCC derive_control_track #-}
derive_control_track :: Derive.CallableExpr d => Derive.State -> TrackInfo d
    -> DeriveResult d
derive_control_track :: forall d. CallableExpr d => State -> TrackInfo d -> DeriveResult d
derive_control_track State
state TrackInfo d
tinfo =
    forall d a.
Taggable d =>
Track -> ((State, Maybe d), a) -> (a, Threaded, Collect)
post_track Track
track forall a b. (a -> b) -> a -> b
$ forall {a} {b} {b} {b}. ((a, b, b), b) -> ((a, b), b)
use_save_val forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL (forall d.
CallableExpr d =>
TrackInfo d
-> (State, Maybe d, Maybe d)
-> ([Event], [Event])
-> ((State, Maybe d, Maybe d), Stream d)
derive_control_track_stream TrackInfo d
tinfo) (State, Maybe d, Maybe d)
initial_state
        (forall d. TrackInfo d -> [([Event], [Event])]
event_prev_nexts TrackInfo d
tinfo)
    where
    initial_state :: (State, Maybe d, Maybe d)
initial_state = (Track -> State -> State
record_track_dynamic Track
track State
state, Maybe d
val, Maybe d
val)
        where val :: Maybe d
val = forall a. Taggable a => Track -> State -> Maybe a
lookup_prev_val Track
track State
state
    track :: Track
track = forall d. TrackInfo d -> Track
tinfo_track TrackInfo d
tinfo
    use_save_val :: ((a, b, b), b) -> ((a, b), b)
use_save_val ((a
state, b
_, b
save_val), b
result) = ((a
state, b
save_val), b
result)

{- | This is the note track version of 'derive_control_track'.  The main
    difference is that it evaluates orphans.

    Orphans are uncovered events in note tracks in the sub-tracks.  They are
    extracted with 'Slice.checked_slice_notes' and evaluated as-is.  The effect
    is that note parents can be stacked horizontally, and tracks left empty
    have no effect, except whatever transformers they may have in their titles.

    This is all very complicated and unsatisfactory, but it's still less
    complicated and somewhat more satisfactory than it used to be, if you can
    imagine that.
-}
{-# SCC derive_note_track #-}
derive_note_track :: (TrackTree.EventsTree -> Derive.NoteDeriver)
    -> Derive.State -> TrackInfo Score.Event -> DeriveResult Score.Event
derive_note_track :: (EventsTree -> NoteDeriver)
-> State -> TrackInfo Event -> DeriveResult Event
derive_note_track EventsTree -> NoteDeriver
derive_tracks State
state TrackInfo Event
tinfo
    | Track -> Sliced
TrackTree.track_sliced (forall d. TrackInfo d -> Track
tinfo_track TrackInfo Event
tinfo) forall a. Eq a => a -> a -> Bool
== Sliced
TrackTree.Inversion =
        State -> TrackInfo Event -> Inversion -> DeriveResult Event
derive_inverted State
state TrackInfo Event
tinfo forall a b. (a -> b) -> a -> b
$
        Dynamic -> Inversion
Derive.state_inversion (State -> Dynamic
Derive.state_dynamic State
state)
    | Bool
otherwise = (EventsTree -> NoteDeriver)
-> State -> TrackInfo Event -> DeriveResult Event
derive_note_track_ EventsTree -> NoteDeriver
derive_tracks State
state TrackInfo Event
tinfo

-- This function is split out from 'derive_note_track' to emphasize the shared
-- structure with 'derive_control_track'.
derive_note_track_ :: (TrackTree.EventsTree -> Derive.NoteDeriver)
    -> Derive.State -> TrackInfo Score.Event
    -> ([Stream.Stream Score.Event], Derive.Threaded, Derive.Collect)
derive_note_track_ :: (EventsTree -> NoteDeriver)
-> State -> TrackInfo Event -> DeriveResult Event
derive_note_track_ EventsTree -> NoteDeriver
derive_tracks State
state TrackInfo Event
tinfo =
    forall d a.
Taggable d =>
Track -> ((State, Maybe d), a) -> (a, Threaded, Collect)
post_track Track
track forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL ((EventsTree -> NoteDeriver)
-> TrackInfo Event
-> (State, Maybe Event)
-> ([Event], [Event])
-> ((State, Maybe Event), Stream Event)
derive_note_track_stream EventsTree -> NoteDeriver
derive_tracks TrackInfo Event
tinfo) (State, Maybe Event)
initial_state
        (forall d. TrackInfo d -> [([Event], [Event])]
event_prev_nexts TrackInfo Event
tinfo)
    where
    initial_state :: (State, Maybe Event)
initial_state = (Track -> State -> State
record_track_dynamic Track
track State
state, Maybe Event
val)
        where val :: Maybe Event
val = forall a. Taggable a => Track -> State -> Maybe a
lookup_prev_val Track
track State
state
    track :: Track
track = forall d. TrackInfo d -> Track
tinfo_track TrackInfo Event
tinfo

-- I used to use the same function to derive note and control tracks.  However,
-- over time control and note tracks gradually gained separate features, and
-- the function became more complicated to accommodate the differences.
-- Eventually I just split them into separate functions.  The result is
-- simpler, but there is a certain amount of duplicated code between them.
-- So if you modify one, make sure you also modify the other if applicable.

derive_inverted :: Derive.State -> TrackInfo Score.Event
    -> Derive.Inversion -> DeriveResult Score.Event
derive_inverted :: State -> TrackInfo Event -> Inversion -> DeriveResult Event
derive_inverted State
state_ TrackInfo Event
tinfo Inversion
inversion =
    ([Stream Event
levents], Threaded
threaded, State -> Collect
Derive.state_collect State
next_state)
    where
    (Stream Event
levents, State
next_state) = forall d. State -> Deriver (Stream d) -> (Stream d, State)
run_derive State
state forall a b. (a -> b) -> a -> b
$ case Inversion
inversion of
        Inversion
Derive.NotInverted ->
            forall a. Stack => Text -> Deriver a
Derive.throw Text
"inverted track didn't set state_inversion"
        Derive.InversionInProgress NoteDeriver
generator -> forall d a. TrackInfo d -> Deriver a -> Deriver a
with_inverted TrackInfo Event
tinfo forall a b. (a -> b) -> a -> b
$
            Dynamic -> NoteDeriver -> NoteDeriver
Derive.state_under_invert (State -> Dynamic
Derive.state_dynamic State
state) NoteDeriver
generator
    threaded :: Threaded
threaded = forall a. Taggable a => Track -> Maybe a -> Threaded -> Threaded
stash_prev_val Track
track Maybe Event
next_val forall a b. (a -> b) -> a -> b
$ State -> Threaded
Derive.state_threaded State
next_state
    prev_val :: Maybe Event
prev_val = forall a. Taggable a => Track -> State -> Maybe a
lookup_prev_val Track
track State
state_
    next_val :: Maybe Event
next_val = forall d. TrackInfo d -> Maybe d -> Stream d -> Maybe d
tinfo_prev_val TrackInfo Event
tinfo Maybe Event
prev_val Stream Event
levents
    track :: Track
track = forall d. TrackInfo d -> Track
tinfo_track TrackInfo Event
tinfo
    state :: State
state = Track -> State -> State
record_track_dynamic Track
track State
state_

-- | Update Dynamic before evaluating the inverted generator.
with_inverted :: TrackInfo d -> Derive.Deriver a -> Derive.Deriver a
with_inverted :: forall d a. TrackInfo d -> Deriver a -> Deriver a
with_inverted TrackInfo d
tinfo = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local forall a b. (a -> b) -> a -> b
$ \Dynamic
state ->
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Frame -> Dynamic -> Dynamic
Internal.add_stack_frame Maybe Frame
frame forall a b. (a -> b) -> a -> b
$ Dynamic
state
        { state_inversion :: Inversion
Derive.state_inversion = Inversion
Derive.NotInverted }
    where
    -- The region is redundant, since the uninverted call has already put it on
    -- the stack, but inversion causes the tracks to go on the stack again, and
    -- if I don't put the region on then the [block, track, region] order is
    -- messed up.
    -- TODO should I put the call name on again?  I could stash it in the event
    -- text.
    frame :: Maybe Frame
frame = (\Event
e -> ScoreTime -> ScoreTime -> Frame
Stack.Region (Event -> ScoreTime
Event.min Event
e forall a. Num a => a -> a -> a
+ ScoreTime
shifted) (Event -> ScoreTime
Event.max Event
e forall a. Num a => a -> a -> a
+ ScoreTime
shifted))
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Event
maybe_event
    shifted :: ScoreTime
shifted = Track -> ScoreTime
TrackTree.track_shifted (forall d. TrackInfo d -> Track
tinfo_track TrackInfo d
tinfo)
    maybe_event :: Maybe Event
maybe_event = Events -> Maybe Event
Events.head forall a b. (a -> b) -> a -> b
$ Track -> Events
TrackTree.track_events forall a b. (a -> b) -> a -> b
$ forall d. TrackInfo d -> Track
tinfo_track TrackInfo d
tinfo

-- | Extract the final state at the end of a track derivation.
post_track :: Derive.Taggable d => TrackTree.Track
    -> ((Derive.State, Maybe d), a) -> (a, Derive.Threaded, Derive.Collect)
post_track :: forall d a.
Taggable d =>
Track -> ((State, Maybe d), a) -> (a, Threaded, Collect)
post_track Track
track ((State
state, Maybe d
save_val), a
result) =
    ( a
result
    , forall a. Taggable a => Track -> Maybe a -> Threaded -> Threaded
stash_prev_val Track
track Maybe d
save_val forall a b. (a -> b) -> a -> b
$ State -> Threaded
Derive.state_threaded State
state
    , State -> Collect
Derive.state_collect State
state
    )

-- | Get all event prefixes and suffixes.
event_prev_nexts :: TrackInfo d -> [([Event.Event], [Event.Event])]
event_prev_nexts :: forall d. TrackInfo d -> [([Event], [Event])]
event_prev_nexts =
    forall a. [a] -> [a] -> [([a], [a])]
Lists.zipper [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> [Event]
Events.ascending forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Events
TrackTree.track_events forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. TrackInfo d -> Track
tinfo_track

-- | Derive one event on a control track.  Carrying previous values forward
-- on a control track is a bit more complicated, because there is a separate
-- next_val and save_val.  The next_val should be the next event's prev_val,
-- and the save_val should be saved as the final next_val at the end of the
-- track.  The reason is that I only save a prev val if the event won't be
-- derived again, e.g.  there's a future event <= the start of the next slice.
-- Otherwise, a sliced event will see its own output as its previous val.
derive_control_track_stream :: Derive.CallableExpr d
    => TrackInfo d
    -> (Derive.State, Maybe d, Maybe d)
    -> ([Event.Event], [Event.Event])
    -> ((Derive.State, Maybe d, Maybe d), Stream.Stream d)
derive_control_track_stream :: forall d.
CallableExpr d =>
TrackInfo d
-> (State, Maybe d, Maybe d)
-> ([Event], [Event])
-> ((State, Maybe d, Maybe d), Stream d)
derive_control_track_stream TrackInfo d
tinfo (State
prev_state, Maybe d
prev_val, Maybe d
prev_save_val)
        ([Event]
prev_events, [Event]
cur_events) =
    ((State
state, Maybe d
next_val, Maybe d
save_val), Stream d
stream)
    where
    (Stream d
stream, State
state) = case Maybe (Deriver (Stream d))
derivers of
        Just Deriver (Stream d)
deriver -> forall d. State -> Deriver (Stream d) -> (Stream d, State)
run_derive (State -> State
reset_event_serial State
prev_state) Deriver (Stream d)
deriver
        Maybe (Deriver (Stream d))
Nothing -> (forall a. Stream a
Stream.empty, State
prev_state)
    derivers :: Maybe (Deriver (Stream d))
derivers = case [Event]
cur_events of
        Event
event : [Event]
next_events -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            forall d.
CallableExpr d =>
Context d -> Event -> Deriver (Stream d)
derive_event (forall a val.
TrackInfo a
-> Maybe val -> [Event] -> Event -> [Event] -> Context val
context TrackInfo d
tinfo Maybe d
prev_val [Event]
prev_events Event
event [Event]
next_events)
                Event
event
        [] -> forall a. Maybe a
Nothing
    next_val :: Maybe d
next_val = forall d. TrackInfo d -> Maybe d -> Stream d -> Maybe d
tinfo_prev_val TrackInfo d
tinfo Maybe d
prev_val Stream d
stream
    save_val :: Maybe d
save_val = if Bool
should_save_val then Maybe d
next_val else Maybe d
prev_save_val
    should_save_val :: Bool
should_save_val = case [Event]
cur_events of
        Event
_ : Event
next : [Event]
_ ->
            Event -> ScoreTime
Event.start Event
next forall a. Ord a => a -> a -> Bool
<= Track -> ScoreTime
TrackTree.track_end (forall d. TrackInfo d -> Track
tinfo_track TrackInfo d
tinfo)
        [Event]
_ -> Bool
False

-- | Derive one event on a note track.  This also derives orphan events
-- before the event, or after the last event.
{-# SCC derive_note_track_stream #-}
derive_note_track_stream :: (TrackTree.EventsTree -> Derive.NoteDeriver)
    -> TrackInfo Score.Event
    -> (Derive.State, Maybe Score.Event)
    -> ([Event.Event], [Event.Event])
    -> ((Derive.State, Maybe Score.Event), Stream.Stream Score.Event)
derive_note_track_stream :: (EventsTree -> NoteDeriver)
-> TrackInfo Event
-> (State, Maybe Event)
-> ([Event], [Event])
-> ((State, Maybe Event), Stream Event)
derive_note_track_stream EventsTree -> NoteDeriver
derive_tracks TrackInfo Event
tinfo (State
prev_state, Maybe Event
prev_val)
        ([Event]
prev_events, [Event]
cur_events) =
    ((State
next_state, Maybe Event
next_val), Stream Event
stream)
    where
    (Stream Event
stream, State
next_state)
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NoteDeriver]
derivers = (forall a. Stream a
Stream.empty, State
prev_state)
        | Bool
otherwise = forall d. State -> Deriver (Stream d) -> (Stream d, State)
run_derive (State -> State
reset_event_serial State
prev_state)
            (forall a. Monoid a => [a] -> a
mconcat [NoteDeriver]
derivers)
    derivers :: [NoteDeriver]
derivers = forall a. [Maybe a] -> [a]
Maybe.catMaybes forall a b. (a -> b) -> a -> b
$ case [Event]
cur_events of
        Event
event : [Event]
next_events ->
            [ Maybe Event -> Maybe Event -> Maybe NoteDeriver
derive_empty (forall a. [a] -> Maybe a
Lists.head [Event]
prev_events) (forall a. a -> Maybe a
Just Event
event)
            , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Event -> [Event] -> NoteDeriver
derive_note Event
event [Event]
next_events
            ]
        [] -> [Maybe Event -> Maybe Event -> Maybe NoteDeriver
derive_empty (forall a. [a] -> Maybe a
Lists.head [Event]
prev_events) forall a. Maybe a
Nothing]
    derive_note :: Event -> [Event] -> NoteDeriver
derive_note Event
event [Event]
next_events = forall d.
CallableExpr d =>
Context d -> Event -> Deriver (Stream d)
derive_event Context Event
ctx Event
event
        where ctx :: Context Event
ctx = forall a val.
TrackInfo a
-> Maybe val -> [Event] -> Event -> [Event] -> Context val
context TrackInfo Event
tinfo Maybe Event
prev_val [Event]
prev_events Event
event [Event]
next_events
    next_val :: Maybe Event
next_val = forall d. TrackInfo d -> Maybe d -> Stream d -> Maybe d
tinfo_prev_val TrackInfo Event
tinfo Maybe Event
prev_val Stream Event
stream
    -- Look for orphans in the gap between events.
    derive_empty :: Maybe Event -> Maybe Event -> Maybe NoteDeriver
derive_empty Maybe Event
prev Maybe Event
next =
        (EventsTree -> NoteDeriver)
-> Maybe Event -> ScoreTime -> EventsTree -> Maybe NoteDeriver
derive_orphans EventsTree -> NoteDeriver
derive_tracks Maybe Event
prev ScoreTime
end (forall d. TrackInfo d -> EventsTree
tinfo_sub_tracks TrackInfo Event
tinfo)
        where
        end :: ScoreTime
end = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Track -> ScoreTime
TrackTree.track_end (forall d. TrackInfo d -> Track
tinfo_track TrackInfo Event
tinfo)) Event -> ScoreTime
Event.start Maybe Event
next

-- | See 'Derive.state_event_serial' for what this is doing.
reset_event_serial :: Derive.State -> Derive.State
reset_event_serial :: State -> State
reset_event_serial State
state =
    case Dynamic -> Inversion
Derive.state_inversion (State -> Dynamic
Derive.state_dynamic State
state) of
        Inversion
Derive.NotInverted -> State
state
            { state_threaded :: Threaded
Derive.state_threaded = (State -> Threaded
Derive.state_threaded State
state)
                { state_event_serial :: Serial
Derive.state_event_serial = Serial
0 }
            }
        Inversion
_ -> State
state

lookup_prev_val :: Derive.Taggable a => TrackTree.Track -> Derive.State
    -> Maybe a
lookup_prev_val :: forall a. Taggable a => Track -> State -> Maybe a
lookup_prev_val Track
track State
state = do
    (BlockId, TrackId)
block_track <- Track -> Maybe (BlockId, TrackId)
TrackTree.block_track_id Track
track
    Tagged
tagged <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (BlockId, TrackId)
block_track forall a b. (a -> b) -> a -> b
$
        Threaded -> Map (BlockId, TrackId) Tagged
Derive.state_prev_val (State -> Threaded
Derive.state_threaded State
state)
    forall a. Taggable a => Tagged -> Maybe a
Derive.from_tagged Tagged
tagged

stash_prev_val :: Derive.Taggable a => TrackTree.Track -> Maybe a
    -> Derive.Threaded -> Derive.Threaded
stash_prev_val :: forall a. Taggable a => Track -> Maybe a -> Threaded -> Threaded
stash_prev_val Track
track Maybe a
prev_val Threaded
threaded = forall a. a -> Maybe a -> a
fromMaybe Threaded
threaded forall a b. (a -> b) -> a -> b
$ do
    a
val <- Maybe a
prev_val
    (BlockId, TrackId)
block_track <- Track -> Maybe (BlockId, TrackId)
TrackTree.block_track_id Track
track
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Threaded
threaded
        { state_prev_val :: Map (BlockId, TrackId) Tagged
Derive.state_prev_val = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (BlockId, TrackId)
block_track (forall a. Taggable a => a -> Tagged
Derive.to_tagged a
val)
            (Threaded -> Map (BlockId, TrackId) Tagged
Derive.state_prev_val Threaded
threaded)
        }

-- | Run a derivation.  If the deriver throws an exception, it will be caught
-- and turned into a log msg, and any state changes rolled back.
-- 'Internal.local' relies on this, since it doesn't revert the state after an
-- exception.
run_derive :: Derive.State -> Derive.Deriver (Stream.Stream d)
    -> (Stream.Stream d, Derive.State)
run_derive :: forall d. State -> Deriver (Stream d) -> (Stream d, State)
run_derive State
state Deriver (Stream d)
deriver = case Either Error (Stream d)
result of
    Right Stream d
stream -> (forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs [Msg]
logs Stream d
stream, State
out_state)
    Left Error
err -> (forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs [Msg]
logs (forall {a}. Error -> Stream a
error_to_stream Error
err), State
state)
    where
    error_to_stream :: Error -> Stream a
error_to_stream = forall a. [Msg] -> Stream a
Stream.from_logs forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Msg
Derive.error_to_warn
    (Either Error (Stream d)
result, State
out_state, [Msg]
logs) = forall st err a. st -> Deriver st err a -> RunResult st err a
Derive.run State
state Deriver (Stream d)
deriver

derive_orphans :: (TrackTree.EventsTree -> Derive.NoteDeriver)
    -> Maybe Event.Event -> TrackTime -> TrackTree.EventsTree
    -> Maybe Derive.NoteDeriver
    -- ^ The Maybe is a micro-optimization to avoid returning 'mempty'.  This
    -- is because 'Derive.d_merge' doesn't know that one of its operands is
    -- empty, and does all the splitting of and restoring collect bother.
    -- I expect lots of empties here so maybe it makes a difference.
derive_orphans :: (EventsTree -> NoteDeriver)
-> Maybe Event -> ScoreTime -> EventsTree -> Maybe NoteDeriver
derive_orphans EventsTree -> NoteDeriver
derive_tracks Maybe Event
prev ScoreTime
end EventsTree
subs
    | ScoreTime
start forall a. Ord a => a -> a -> Bool
>= ScoreTime
end = forall a. Maybe a
Nothing
    | Bool
otherwise = case Either Text EventsTree
checked of
        Left Text
err -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn Text
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty
        Right [] -> forall a. Maybe a
Nothing
        Right EventsTree
slices -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ EventsTree -> NoteDeriver
derive_tracks EventsTree
slices
    where
    checked :: Either Text EventsTree
checked = Bool
-> ScoreTime -> ScoreTime -> EventsTree -> Either Text EventsTree
Slice.slice_orphans Bool
exclude_start ScoreTime
start ScoreTime
end EventsTree
subs
    exclude_start :: Bool
exclude_start = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((forall a. Eq a => a -> a -> Bool
==ScoreTime
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> ScoreTime
Event.duration) Maybe Event
prev
    start :: ScoreTime
start = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScoreTime
0 Event -> ScoreTime
Event.end Maybe Event
prev

-- Notes on recording TrackDynamic at NOTE [record-track-dynamics].
--
-- I want controls from the first uninverted version (might be sliced because
-- a child note track will only ever be evaluated sliced), and the rest from
-- the first inverted version.
record_track_dynamic :: TrackTree.Track -> Derive.State -> Derive.State
record_track_dynamic :: Track -> State -> State
record_track_dynamic Track
track State
state =
    -- TODO I feel like I should merge this with the existing collect, but
    -- profiling shows that it kills performance.  Perhaps I wind up
    -- duplicating the collect and doing a bunch of extra merging every
    -- (inverted) event.  I'm not sure at the moment, but it should be safe to
    -- start with an empty collect anyway.
    State
state { state_collect :: Collect
Derive.state_collect = Collect
collect }
    where
    collect :: Collect
collect = case Dynamic -> Maybe TrackDynamic
Internal.record_track_dynamic (State -> Dynamic
Derive.state_dynamic State
state) of
        Maybe TrackDynamic
Nothing -> forall a. Monoid a => a
mempty
        Just TrackDynamic
track_dyn
            | Track -> Sliced
TrackTree.track_sliced Track
track forall a. Eq a => a -> a -> Bool
== Sliced
TrackTree.Inversion -> forall a. Monoid a => a
mempty
                { collect_track_dynamic_inverted :: TrackDynamic
Derive.collect_track_dynamic_inverted = TrackDynamic
track_dyn }
            | Bool
otherwise -> forall a. Monoid a => a
mempty { collect_track_dynamic :: TrackDynamic
Derive.collect_track_dynamic = TrackDynamic
track_dyn }

defragment_track_signals :: Warp.Warp -> Derive.Collect -> Derive.Collect
defragment_track_signals :: Warp -> Collect -> Collect
defragment_track_signals Warp
warp Collect
collect
    | forall k a. Map k a -> Bool
Map.null SignalFragments
fragments = Collect
collect
    | Bool
otherwise = Collect
collect
        { collect_track_signals :: TrackSignals
Derive.collect_track_signals = Collect -> TrackSignals
Derive.collect_track_signals Collect
collect
            forall a. Semigroup a => a -> a -> a
<> forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall {k}. Map k Control -> TrackSignal
defragment SignalFragments
fragments
        , collect_signal_fragments :: SignalFragments
Derive.collect_signal_fragments = forall a. Monoid a => a
mempty
        }
    where
    fragments :: SignalFragments
fragments = Collect -> SignalFragments
Derive.collect_signal_fragments Collect
collect
    defragment :: Map k Control -> TrackSignal
defragment = Warp -> Control -> TrackSignal
unwarp Warp
warp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems

unwarp :: Warp.Warp -> Signal.Control -> Track.TrackSignal
unwarp :: Warp -> Control -> TrackSignal
unwarp Warp
warp Control
control = case Warp -> Maybe Linear
Warp.is_linear Warp
warp of
    Just Linear
linear -> Track.TrackSignal
        { ts_signal :: Display
ts_signal = forall {k1} {k2} (kind1 :: k1) (kind2 :: k2).
Signal kind1 -> Signal kind2
Signal.coerce Control
control
        , ts_shift :: ScoreTime
ts_shift = RealTime -> ScoreTime
RealTime.to_score (Linear -> RealTime
Warp._shift Linear
linear)
        , ts_stretch :: ScoreTime
ts_stretch = RealTime -> ScoreTime
RealTime.to_score (Linear -> RealTime
Warp._stretch Linear
linear)
        }
    Maybe Linear
Nothing -> Track.TrackSignal
        { ts_signal :: Display
ts_signal = Warp -> Control -> Display
Warp.unwarp_signal Warp
warp Control
control
        , ts_shift :: ScoreTime
ts_shift = ScoreTime
0
        , ts_stretch :: ScoreTime
ts_stretch = ScoreTime
1
        }

{-# SCC derive_event #-}
derive_event :: Derive.CallableExpr d => Derive.Context d -> Event.Event
    -> Derive.Deriver (Stream.Stream d)
derive_event :: forall d.
CallableExpr d =>
Context d -> Event -> Deriver (Stream d)
derive_event Context d
ctx Event
event
    | Text
Config.event_comment Text -> Text -> Bool
`Text.isPrefixOf` (Char -> Bool) -> Text -> Text
Text.dropWhile (forall a. Eq a => a -> a -> Bool
==Char
' ') Text
text =
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty
    | Bool
otherwise = forall a. ScoreTime -> Event -> Deriver a -> Deriver a
with_event_region (forall val. Context val -> ScoreTime
Derive.ctx_track_shifted Context d
ctx) Event
event forall a b. (a -> b) -> a -> b
$
        case Text -> Either Text Expr
Parse.parse_expr Text
text of
            Left Text
err -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn Text
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty
            Right Expr
expr -> forall {a}. Deriver a -> Deriver a
with_note_start_end forall a b. (a -> b) -> a -> b
$ forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
Eval.eval_toplevel Context d
ctx Expr
expr
    where
    text :: Text
text = Event -> Text
Event.text Event
event
    with_note_start_end :: Deriver a -> Deriver a
with_note_start_end = case forall val. Context val -> Maybe Type
Derive.ctx_track_type Context d
ctx of
        Just Type
ParseTitle.NoteTrack -> forall val a. ToVal val => [(Text, val)] -> Deriver a -> Deriver a
Derive.with_vals
                [ (Text
EnvKey.note_start, Event -> ScoreTime
Event.start Event
event)
                , (Text
EnvKey.note_end, Event -> ScoreTime
Event.end Event
event)
                ]
            where event :: Event
event = forall val. Context val -> Event
Derive.ctx_event Context d
ctx
        Maybe Type
_ -> forall a. a -> a
id

with_event_region :: ScoreTime -> Event.Event -> Derive.Deriver a
    -> Derive.Deriver a
with_event_region :: forall a. ScoreTime -> Event -> Deriver a -> Deriver a
with_event_region ScoreTime
track_shifted Event
event =
    forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Internal.with_stack_region (Event -> ScoreTime
Event.min Event
event forall a. Num a => a -> a -> a
+ ScoreTime
track_shifted)
        (Event -> ScoreTime
Event.max Event
event forall a. Num a => a -> a -> a
+ ScoreTime
track_shifted)

context :: TrackInfo a -> Maybe val
    -> [Event.Event] -- ^ previous events, in reverse order
    -> Event.Event -- ^ cur event
    -> [Event.Event] -- ^ following events
    -> Derive.Context val
context :: forall a val.
TrackInfo a
-> Maybe val -> [Event] -> Event -> [Event] -> Context val
context TrackInfo a
tinfo Maybe val
prev_val [Event]
prev Event
event [Event]
next = Derive.Context
    { ctx_prev_val :: Maybe val
Derive.ctx_prev_val = Maybe val
prev_val
    , ctx_event :: Event
Derive.ctx_event = Event
event
    -- Augment prev and next with the unevaluated "around" notes from
    -- 'State.track_around'.
    , ctx_prev_events :: [Event]
Derive.ctx_prev_events = [Event]
tprev forall a. [a] -> [a] -> [a]
++ [Event]
prev
    , ctx_next_events :: [Event]
Derive.ctx_next_events = [Event]
next forall a. [a] -> [a] -> [a]
++ [Event]
tnext
    , ctx_event_end :: ScoreTime
Derive.ctx_event_end = case [Event]
next forall a. [a] -> [a] -> [a]
++ [Event]
tnext of
        [] -> Track -> ScoreTime
TrackTree.track_end Track
track
        Event
event : [Event]
_ -> Event -> ScoreTime
Event.start Event
event
    , ctx_track_shifted :: ScoreTime
Derive.ctx_track_shifted = Track -> ScoreTime
TrackTree.track_shifted Track
track
    , ctx_sub_tracks :: EventsTree
Derive.ctx_sub_tracks = EventsTree
subs
    , ctx_sub_events :: Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Derive.ctx_sub_events = forall a. Maybe a
Nothing
    , ctx_track_type :: Maybe Type
Derive.ctx_track_type = forall a. a -> Maybe a
Just Type
ttype
    }
    where
    TrackInfo Track
track EventsTree
subs Type
ttype GetLastVal a
_ = TrackInfo a
tinfo
    ([Event]
tprev, [Event]
tnext) = Track -> ([Event], [Event])
TrackTree.track_around Track
track