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