-- 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 {- | This module is sister to "Derive.Deriver.Lib", except that it contains functions which are normally only used by the built-in track derivation scheme, and are not used when writing most normal calls. -} module Derive.Deriver.Internal where import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Util.CallStack as CallStack import qualified Util.Log as Log import qualified Util.Seed as Seed import qualified Derive.DeriveT as DeriveT import qualified Derive.EnvKey as EnvKey import qualified Derive.ScoreT as ScoreT import qualified Derive.Stack as Stack import qualified Derive.TrackWarp as TrackWarp import qualified Derive.Warp as Warp import qualified Ui.Block as Block import qualified Ui.Ruler as Ruler import qualified Ui.Track as Track import qualified Ui.Ui as Ui import qualified Ui.UiConfig as UiConfig import Derive.Deriver.Monad import Global import Types -- * generic state access get_dynamic :: (Dynamic -> a) -> Deriver a get_dynamic :: forall a. (Dynamic -> a) -> Deriver a get_dynamic Dynamic -> a f = forall st a err. (st -> a) -> Deriver st err a gets (Dynamic -> a f forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> Dynamic state_dynamic) get_constant :: (Constant -> a) -> Deriver a get_constant :: forall a. (Constant -> a) -> Deriver a get_constant Constant -> a f = forall st a err. (st -> a) -> Deriver st err a gets (Constant -> a f forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> Constant state_constant) -- | This is a little different from Reader.local because only a portion of -- the state is used Reader-style. -- -- Note that this doesn't restore the state on an exception. I think this -- is ok because exceptions are always \"caught\" at the event evaluation -- level since it runs each one separately. Since the state dynamic state -- (i.e. except Collect) from the sub derivation is discarded, whatever state -- it's in after the exception shouldn't matter. local :: (Dynamic -> Dynamic) -> Deriver a -> Deriver a local :: forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a local Dynamic -> Dynamic modify_dynamic = forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a localm (forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . Dynamic -> Dynamic modify_dynamic) localm :: (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a localm :: forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a localm Dynamic -> Deriver Dynamic modify_dynamic Deriver a deriver = do State st <- forall st err. Deriver st err st get Dynamic new <- Dynamic -> Deriver Dynamic modify_dynamic (State -> Dynamic state_dynamic State st) forall st err. st -> Deriver st err () put forall a b. (a -> b) -> a -> b $ State st { state_dynamic :: Dynamic state_dynamic = Dynamic new } a result <- Deriver a deriver forall st err. (st -> st) -> Deriver st err () modify forall a b. (a -> b) -> a -> b $ \State new -> State new { state_dynamic :: Dynamic state_dynamic = State -> Dynamic state_dynamic State st } forall (m :: * -> *) a. Monad m => a -> m a return a result -- | A version of 'local' that catches exceptions and ignores any changes to -- Collect. This is appropriate for sub-calls that are below normal track -- derivation. detached_local :: (Dynamic -> Dynamic) -> Deriver a -> Deriver (Either Error a) detached_local :: forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver (Either Error a) detached_local Dynamic -> Dynamic modify_dynamic Deriver a deriver = do State st <- forall st err. Deriver st err st get let (Either Error a result, State _, [Msg] logs) = forall st err a. st -> Deriver st err a -> RunResult st err a run (State st { state_dynamic :: Dynamic state_dynamic = Dynamic -> Dynamic modify_dynamic (State -> Dynamic state_dynamic State st) }) Deriver a deriver forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ forall (m :: * -> *). LogMonad m => Msg -> m () Log.write [Msg] logs forall (m :: * -> *) a. Monad m => a -> m a return Either Error a result set_threaded :: Threaded -> Deriver () set_threaded :: Threaded -> Deriver State Error () set_threaded Threaded threaded = forall st err. (st -> st) -> Deriver st err () modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_threaded :: Threaded state_threaded = Threaded threaded } -- * Collect -- | Collect is only ever accumulated. -- -- Direct modification would be potentially more efficient, but according to -- profiling it doesn't make a difference. merge_collect :: Collect -> Deriver () merge_collect :: Collect -> Deriver State Error () merge_collect Collect c = forall st err. (st -> st) -> Deriver st err () modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_collect :: Collect state_collect = State -> Collect state_collect State st forall a. Semigroup a => a -> a -> a <> Collect c } -- I append the Collect, which means that I wind up with the first instance -- for Maps with duplicate keys. This seems a bit more intuitive than the -- last one. -- | Run with an empty Collect, restore the original Collect, and return the -- sub-deriver's Collect. local_collect :: Deriver a -> Deriver (a, Collect) local_collect :: forall a. Deriver a -> Deriver (a, Collect) local_collect Deriver a deriver = do Collect old <- forall st a err. (st -> a) -> Deriver st err a gets State -> Collect state_collect forall st err. (st -> st) -> Deriver st err () modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_collect :: Collect state_collect = forall a. Monoid a => a mempty } a result <- Deriver a deriver Collect sub_collect <- forall st a err. (st -> a) -> Deriver st err a gets State -> Collect state_collect forall st err. (st -> st) -> Deriver st err () modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_collect :: Collect state_collect = Collect old } forall (m :: * -> *) a. Monad m => a -> m a return (a result, Collect sub_collect) -- | Modify the 'collect_warp_map' to reduce the start and end by the given -- times. This is useful if you're going to clip off some events. The -- TrackWarps, and hence playback cursor, can't know you're going to do this, -- so you have to tell it. trim_track_warps :: Maybe RealTime -> Maybe RealTime -> Deriver a -> Deriver a trim_track_warps :: forall a. Maybe RealTime -> Maybe RealTime -> Deriver a -> Deriver a trim_track_warps Maybe RealTime start Maybe RealTime end = forall a. (Collect -> Collect) -> Deriver a -> Deriver a with_collect forall a b. (a -> b) -> a -> b $ \Collect st -> Collect st { collect_warp_map :: WarpMap collect_warp_map = Track -> Track trim forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Collect -> WarpMap collect_warp_map Collect st } where trim :: Track -> Track trim (TrackWarp.Track RealTime s RealTime e Warp warp BlockId block_id Maybe TrackId track_id) = RealTime -> RealTime -> Warp -> BlockId -> Maybe TrackId -> Track TrackWarp.Track (forall b a. b -> (a -> b) -> Maybe a -> b maybe RealTime s (forall a. Ord a => a -> a -> a max RealTime s) Maybe RealTime start) (forall b a. b -> (a -> b) -> Maybe a -> b maybe RealTime e (forall a. Ord a => a -> a -> a min RealTime e) Maybe RealTime end) Warp warp BlockId block_id Maybe TrackId track_id -- | Run the deriver and modify the Collect it returns. with_collect :: (Collect -> Collect) -> Deriver a -> Deriver a with_collect :: forall a. (Collect -> Collect) -> Deriver a -> Deriver a with_collect Collect -> Collect modify Deriver a deriver = do (a a, Collect collect) <- forall a. Deriver a -> Deriver (a, Collect) local_collect Deriver a deriver Collect -> Deriver State Error () merge_collect (Collect -> Collect modify Collect collect) forall (m :: * -> *) a. Monad m => a -> m a return a a -- | TODO this is sketchy, you're supposed to use 'merge_collect'. modify_collect :: (Collect -> Collect) -> Deriver () modify_collect :: (Collect -> Collect) -> Deriver State Error () modify_collect Collect -> Collect f = forall st err. (st -> st) -> Deriver st err () modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_collect :: Collect state_collect = Collect -> Collect f (State -> Collect state_collect State st) } -- * environ get_environ :: Deriver DeriveT.Environ get_environ :: Deriver Environ get_environ = forall a. (Dynamic -> a) -> Deriver a get_dynamic Dynamic -> Environ state_environ -- | Figure out the current block and track, and record the current environ -- in the Collect. It only needs to be recorded once per track. record_track_dynamic :: Dynamic -> Maybe TrackDynamic record_track_dynamic :: Dynamic -> Maybe TrackDynamic record_track_dynamic Dynamic dyn = case Stack -> Maybe (BlockId, TrackId) Stack.block_track_of (Dynamic -> Stack state_stack Dynamic dyn) of Just (BlockId bid, TrackId tid) -> forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $! forall k a. k -> a -> Map k a Map.singleton (BlockId bid, TrackId tid) forall a b. (a -> b) -> a -> b $! -- If I don't clear the inversion state, any inverting call that uses -- this dynamic will throw a double inversion error. Also the function -- closure probably causes drag. Dynamic dyn { state_inversion :: Inversion state_inversion = Inversion NotInverted } Maybe (BlockId, TrackId) Nothing -> forall a. Maybe a Nothing -- | 'record_track_dynamic' for when I already know BlockId and TrackId. record_track_dynamic_for :: BlockId -> TrackId -> Deriver () record_track_dynamic_for :: BlockId -> TrackId -> Deriver State Error () record_track_dynamic_for BlockId block_id TrackId track_id = do Dynamic dynamic <- forall st a err. (st -> a) -> Deriver st err a gets State -> Dynamic state_dynamic Collect -> Deriver State Error () merge_collect forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { collect_track_dynamic :: TrackDynamic collect_track_dynamic = forall k a. k -> a -> Map k a Map.singleton (BlockId block_id, TrackId track_id) Dynamic dynamic } -- * misc Dynamic state with_default_merge :: Map ScoreT.Control Merger -> Deriver a -> Deriver a with_default_merge :: forall a. Map Control Merger -> Deriver a -> Deriver a with_default_merge Map Control Merger defaults = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a local forall a b. (a -> b) -> a -> b $ \Dynamic st -> Dynamic st { state_control_merge_defaults :: Map Control Merger state_control_merge_defaults = Map Control Merger defaults forall a. Semigroup a => a -> a -> a <> Dynamic -> Map Control Merger state_control_merge_defaults Dynamic st } -- * cache with_control_damage :: ControlDamage -> Deriver derived -> Deriver derived with_control_damage :: forall derived. ControlDamage -> Deriver derived -> Deriver derived with_control_damage ControlDamage damage = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a local forall a b. (a -> b) -> a -> b $ \Dynamic st -> Dynamic st { state_control_damage :: ControlDamage state_control_damage = ControlDamage damage } add_block_dep :: BlockId -> Deriver () add_block_dep :: BlockId -> Deriver State Error () add_block_dep BlockId block_id = Collect -> Deriver State Error () merge_collect forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { collect_block_deps :: BlockDeps collect_block_deps = Set BlockId -> BlockDeps BlockDeps (forall a. a -> Set a Set.singleton BlockId block_id) } -- * ui state get_ui_state :: (Ui.State -> a) -> Deriver a get_ui_state :: forall a. (State -> a) -> Deriver a get_ui_state State -> a f = forall st a err. (st -> a) -> Deriver st err a gets (State -> a f forall b c a. (b -> c) -> (a -> b) -> a -> c . Constant -> State state_ui forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> Constant state_constant) get_ui_config :: (UiConfig.Config -> a) -> Deriver a get_ui_config :: forall a. (Config -> a) -> Deriver a get_ui_config Config -> a f = forall a. (State -> a) -> Deriver a get_ui_state (Config -> a f forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> Config Ui.state_config) -- | Because Deriver is not a UiStateMonad. -- -- TODO I suppose it could be, but then I'd be tempted to make -- a ReadOnlyUiStateMonad. And I'd have to merge the exceptions. -- Or just rethrow, right? get_track :: TrackId -> Deriver Track.Track get_track :: TrackId -> Deriver Track get_track TrackId track_id = forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a lookup_id TrackId track_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall a. (State -> a) -> Deriver a get_ui_state State -> Map TrackId Track Ui.state_tracks get_block :: BlockId -> Deriver Block.Block get_block :: BlockId -> Deriver Block get_block BlockId block_id = forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a lookup_id BlockId block_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall a. (State -> a) -> Deriver a get_ui_state State -> Map BlockId Block Ui.state_blocks -- | Evaluate a Ui.M computation, rethrowing any errors. eval_ui :: CallStack.Stack => Ui.StateId a -> Deriver a eval_ui :: forall a. Stack => StateId a -> Deriver a eval_ui StateId a action = do State ui_state <- forall a. (State -> a) -> Deriver a get_ui_state forall a. a -> a id let rethrow :: a -> Deriver a rethrow a exc = forall a. Stack => Text -> Deriver a throw forall a b. (a -> b) -> a -> b $ forall a. Pretty a => a -> Text pretty a exc forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either forall {a} {a}. Pretty a => a -> Deriver a rethrow forall (m :: * -> *) a. Monad m => a -> m a return (forall a. State -> StateId a -> Either Error a Ui.eval State ui_state StateId a action) -- | Lookup @map!key@, throwing if it doesn't exist. lookup_id :: (Ord k, Show k) => k -> Map k a -> Deriver a lookup_id :: forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a lookup_id k key Map k a map = case forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup k key Map k a map of Maybe a Nothing -> forall a. Stack => Text -> Deriver a throw forall a b. (a -> b) -> a -> b $ Text "unknown " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt k key Just a val -> forall (m :: * -> *) a. Monad m => a -> m a return a val -- * stack lookup_current_block_id :: Deriver (Maybe BlockId) lookup_current_block_id :: Deriver (Maybe BlockId) lookup_current_block_id = do Stack stack <- Deriver Stack get_stack forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ case [BlockId bid | Stack.Block BlockId bid <- Stack -> [Frame] Stack.innermost Stack stack] of [] -> forall a. Maybe a Nothing BlockId bid : [BlockId] _ -> forall a. a -> Maybe a Just BlockId bid get_current_block_id :: Deriver BlockId get_current_block_id :: Deriver BlockId get_current_block_id = forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall a. Stack => Text -> Deriver a throw Text "get_current_block_id: no blocks in stack") forall (m :: * -> *) a. Monad m => a -> m a return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Deriver (Maybe BlockId) lookup_current_block_id lookup_current_tracknum :: Deriver (Maybe (BlockId, TrackNum)) lookup_current_tracknum :: Deriver (Maybe (BlockId, Serial)) lookup_current_tracknum = do Stack stack <- Deriver Stack get_stack case Stack -> Maybe (BlockId, TrackId) Stack.block_track_of Stack stack of Maybe (BlockId, TrackId) Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing Just (BlockId block_id, TrackId track_id) -> do Serial tracknum <- forall a. Stack => StateId a -> Deriver a eval_ui forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). M m => BlockId -> TrackId -> m Serial Ui.get_tracknum_of BlockId block_id TrackId track_id forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just (BlockId block_id, Serial tracknum) get_current_tracknum :: Deriver (BlockId, TrackNum) get_current_tracknum :: Deriver (BlockId, Serial) get_current_tracknum = forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall a. Stack => Text -> Deriver a throw Text "get_current_tracknum") forall (m :: * -> *) a. Monad m => a -> m a return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Deriver (Maybe (BlockId, Serial)) lookup_current_tracknum -- | Make a quick trick block stack. {-# SCC with_stack_block #-} with_stack_block :: BlockId -> Deriver a -> Deriver a with_stack_block :: forall a. BlockId -> Deriver a -> Deriver a with_stack_block = forall a. Frame -> Deriver a -> Deriver a with_stack forall b c a. (b -> c) -> (a -> b) -> a -> c . BlockId -> Frame Stack.Block -- | Make a quick trick track stack. {-# SCC with_stack_track #-} with_stack_track :: TrackId -> Deriver a -> Deriver a with_stack_track :: forall a. TrackId -> Deriver a -> Deriver a with_stack_track = forall a. Frame -> Deriver a -> Deriver a with_stack forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackId -> Frame Stack.Track {-# SCC with_stack_region #-} with_stack_region :: ScoreTime -> ScoreTime -> Deriver a -> Deriver a with_stack_region :: forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a with_stack_region ScoreTime s ScoreTime e = forall a. Frame -> Deriver a -> Deriver a with_stack (ScoreTime -> ScoreTime -> Frame Stack.Region ScoreTime s ScoreTime e) {-# SCC with_stack_call #-} with_stack_call :: CallName -> Deriver a -> Deriver a with_stack_call :: forall a. CallName -> Deriver a -> Deriver a with_stack_call (CallName Text name) = forall a. Frame -> Deriver a -> Deriver a with_stack (Text -> Frame Stack.Call Text name) {-# SCC with_stack_serial #-} with_stack_serial :: Int -> Deriver a -> Deriver a with_stack_serial :: forall a. Serial -> Deriver a -> Deriver a with_stack_serial = forall a. Frame -> Deriver a -> Deriver a with_stack forall b c a. (b -> c) -> (a -> b) -> a -> c . Serial -> Frame Stack.Serial with_stack :: Stack.Frame -> Deriver a -> Deriver a with_stack :: forall a. Frame -> Deriver a -> Deriver a with_stack Frame frame = forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a localm forall a b. (a -> b) -> a -> b $ \Dynamic st -> do Stack stack <- Deriver Stack get_stack forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Stack -> Serial Stack.length Stack stack forall a. Ord a => a -> a -> Bool >= Serial max_depth) forall a b. (a -> b) -> a -> b $ forall a. Stack => Text -> Deriver a throw forall a b. (a -> b) -> a -> b $ Text "call stack too deep: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Frame frame forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Frame -> Dynamic -> Dynamic add_stack_frame Frame frame Dynamic st where -- A recursive loop will result in an unfriendly hang. So limit the total -- nesting depth to catch those. I could disallow all recursion, but this -- is more general. max_depth :: Serial max_depth = Serial 100 {- | Add a new stack frame and hash it with the random seed. I skip Stack.Call for seed changes. This is so I can use calls like log-seed to record the seed to hardcode it later, which is the whole point of doing this thing where I hash on every stack frame. Otherwise, the presence of the log-seed call itself would be enough to change the seed. In addition, calculating the seed eagerly this way is actually pretty expensive, since the stack is constantly being updated, so updating it less frequently is good for performance. It's possible I could update the seed lazily to reduce this cost, but not doing something at all is still cheaper than lazy, and can't be accidentally forced. The risk is that this makes the seed too stable, and things which should be randomized become identical. -} add_stack_frame :: Stack.Frame -> Dynamic -> Dynamic add_stack_frame :: Frame -> Dynamic -> Dynamic add_stack_frame Frame frame Dynamic st = Dynamic st { state_stack :: Stack state_stack = Frame -> Stack -> Stack Stack.add Frame frame (Dynamic -> Stack state_stack Dynamic st) , state_environ :: Environ state_environ = (if Frame -> Bool should_update_seed Frame frame then Environ -> Environ update_seed else forall a. a -> a id) (Dynamic -> Environ state_environ Dynamic st) } where should_update_seed :: Frame -> Bool should_update_seed (Stack.Call {}) = Bool False should_update_seed Frame _ = Bool True update_seed :: Environ -> Environ update_seed Environ env = Text -> Val -> Environ -> Environ DeriveT.insert Text EnvKey.seed (Double -> Val DeriveT.num (Double -> Double update Double old)) Environ env where old :: Double old = forall b a. b -> (a -> b) -> Maybe a -> b maybe Double 0 forall a. Typed a -> a ScoreT.val_of forall a b. (a -> b) -> a -> b $ Val -> Maybe (Typed Double) DeriveT.constant_val forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Text -> Environ -> Maybe Val DeriveT.lookup Text EnvKey.seed Environ env update :: Double -> Double update :: Double -> Double update Double n = Serial -> Double i2d (forall a. Seed a => Serial -> a -> Serial Seed.to_seed (forall a b. (RealFrac a, Integral b) => a -> b floor Double n) Frame frame) -- A Double should be able to hold up to 2^52, but that's still an -- annoyingly large number to write in a score, so restrict it further. i2d :: Int -> Double i2d :: Serial -> Double i2d Serial i = forall a b. (Integral a, Num b) => a -> b fromIntegral (Serial i forall a. Integral a => a -> a -> a `mod` Serial 999) get_stack :: Deriver Stack.Stack get_stack :: Deriver Stack get_stack = forall a. (Dynamic -> a) -> Deriver a get_dynamic Dynamic -> Stack state_stack -- ** time and duration -- | Times are types that can be converted to RealTime and ScoreTime. class Time a where real :: a -> Deriver RealTime score :: a -> Deriver ScoreTime to_duration :: a -> DeriveT.Duration instance Time ScoreTime where real :: ScoreTime -> Deriver RealTime real = ScoreTime -> Deriver RealTime score_to_real score :: ScoreTime -> Deriver ScoreTime score = forall (m :: * -> *) a. Monad m => a -> m a return to_duration :: ScoreTime -> Duration to_duration = ScoreTime -> Duration DeriveT.ScoreDuration instance Time RealTime where real :: RealTime -> Deriver RealTime real = forall (m :: * -> *) a. Monad m => a -> m a return score :: RealTime -> Deriver ScoreTime score = RealTime -> Deriver ScoreTime real_to_score to_duration :: RealTime -> Duration to_duration = RealTime -> Duration DeriveT.RealDuration instance Time DeriveT.Duration where real :: Duration -> Deriver RealTime real (DeriveT.RealDuration RealTime t) = forall a. Time a => a -> Deriver RealTime real RealTime t real (DeriveT.ScoreDuration ScoreTime t) = forall a. Time a => a -> Deriver RealTime real ScoreTime t score :: Duration -> Deriver ScoreTime score (DeriveT.RealDuration RealTime t) = forall a. Time a => a -> Deriver ScoreTime score RealTime t score (DeriveT.ScoreDuration ScoreTime t) = forall a. Time a => a -> Deriver ScoreTime score ScoreTime t to_duration :: Duration -> Duration to_duration = forall a. a -> a id -- * warp in_real_time :: Deriver a -> Deriver a in_real_time :: forall a. Deriver a -> Deriver a in_real_time = forall a. (Warp -> Warp) -> Deriver a -> Deriver a with_warp (forall a b. a -> b -> a const Warp Warp.identity) with_warp :: (Warp.Warp -> Warp.Warp) -> Deriver a -> Deriver a with_warp :: forall a. (Warp -> Warp) -> Deriver a -> Deriver a with_warp Warp -> Warp f = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a local forall a b. (a -> b) -> a -> b $ \Dynamic st -> Dynamic st { state_warp :: Warp state_warp = Warp -> Warp f (Dynamic -> Warp state_warp Dynamic st) } get_warp :: Deriver Warp.Warp get_warp :: Deriver Warp get_warp = forall a. (Dynamic -> a) -> Deriver a get_dynamic Dynamic -> Warp state_warp at :: ScoreTime -> Deriver a -> Deriver a at :: forall a. ScoreTime -> Deriver a -> Deriver a at ScoreTime shift = forall a. (Warp -> Warp) -> Deriver a -> Deriver a with_warp forall a b. (a -> b) -> a -> b $ ScoreTime -> Warp -> Warp Warp.shift ScoreTime shift stretch :: ScoreTime -> Deriver a -> Deriver a stretch :: forall a. ScoreTime -> Deriver a -> Deriver a stretch ScoreTime factor = forall a. (Warp -> Warp) -> Deriver a -> Deriver a with_warp forall a b. (a -> b) -> a -> b $ ScoreTime -> Warp -> Warp Warp.stretch ScoreTime factor -- | 'at' and 'stretch' in one. It's a little more efficient than using them -- separately. The order is stretch, then shift. place :: ScoreTime -> ScoreTime -> Deriver a -> Deriver a place :: forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a place ScoreTime shift ScoreTime stretch = forall a. (Warp -> Warp) -> Deriver a -> Deriver a with_warp forall a b. (a -> b) -> a -> b $ ScoreTime -> Warp -> Warp Warp.stretch ScoreTime stretch forall b c a. (b -> c) -> (a -> b) -> a -> c . ScoreTime -> Warp -> Warp Warp.shift ScoreTime shift -- Warp.stretch and Warp.shift look like they're in the wrong order here, -- but they're not. "Derive.Warp" for details. -- | Compose warps. warp :: Warp.Warp -> Deriver a -> Deriver a warp :: forall a. Warp -> Deriver a -> Deriver a warp Warp w | Warp -> Bool Warp.is_identity Warp w = forall a. a -> a id | Bool otherwise = forall a. (Warp -> Warp) -> Deriver a -> Deriver a with_warp (Warp -> Warp -> Warp `Warp.compose` Warp w) -- ** track warp -- | Start a new track warp for the current block_id. -- -- This must be called for each block, and it must be called after the tempo is -- warped for that block so it can install the new warp. add_new_track_warp :: Maybe TrackId -> Deriver () add_new_track_warp :: Maybe TrackId -> Deriver State Error () add_new_track_warp Maybe TrackId maybe_track_id = do Stack stack <- Deriver Stack get_stack BlockId block_id <- Deriver BlockId get_current_block_id RealTime start <- ScoreTime -> Deriver RealTime score_to_real ScoreTime 0 -- Use block_event_end instead of block_logical_range. Otherwise, the play -- monitor can't go past the end of the ruler, while the player is -- perfectly happy to do so. RealTime end <- forall a. Time a => a -> Deriver RealTime real forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< BlockId -> Deriver ScoreTime block_event_end BlockId block_id Warp warp <- Deriver Warp get_warp let track :: Track track = RealTime -> RealTime -> Warp -> BlockId -> Maybe TrackId -> Track TrackWarp.Track RealTime start RealTime end Warp warp BlockId block_id Maybe TrackId maybe_track_id Collect -> Deriver State Error () merge_collect forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { collect_warp_map :: WarpMap collect_warp_map = forall k a. k -> a -> Map k a Map.singleton Stack stack Track track } -- | Sub-derived blocks are stretched according to their length, and this -- function defines the length of a block. This is therefore the logical -- duration of the block, which may be shorter or lorger than the end of the -- last event, or the ruler. block_logical_range :: BlockId -> Deriver (TrackTime, TrackTime) block_logical_range :: BlockId -> Deriver (ScoreTime, ScoreTime) block_logical_range = forall a. Stack => StateId a -> Deriver a eval_ui forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). M m => BlockId -> m (ScoreTime, ScoreTime) Ui.block_logical_range -- | Get the duration of the block according to the last event. block_event_end :: BlockId -> Deriver ScoreTime block_event_end :: BlockId -> Deriver ScoreTime block_event_end = forall a. Stack => StateId a -> Deriver a eval_ui forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). M m => BlockId -> m ScoreTime Ui.block_event_end -- * track -- | The deriver strips out tracks that can't be derived because they have no -- notes. But that means the track warps and track dynamics aren't recorded, -- which means they don't have tempo or a playback monitor, which makes them -- annoying. record_empty_tracks :: [TrackId] -> Deriver () record_empty_tracks :: [TrackId] -> Deriver State Error () record_empty_tracks [] = forall (m :: * -> *) a. Monad m => a -> m a return () record_empty_tracks [TrackId] track_ids = do BlockId block_id <- Deriver BlockId get_current_block_id forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (BlockId -> TrackId -> Deriver State Error () record_empty_track BlockId block_id) [TrackId] track_ids record_empty_track :: BlockId -> TrackId -> Deriver () record_empty_track :: BlockId -> TrackId -> Deriver State Error () record_empty_track BlockId block_id TrackId track_id = BlockId -> TrackId -> Deriver State Error () record_track_dynamic_for BlockId block_id TrackId track_id -- * ControlFunction -- {-# SCC get_control_function_dynamic #-} get_control_function_dynamic :: Deriver DeriveT.Dynamic get_control_function_dynamic :: Deriver Dynamic get_control_function_dynamic = do Marklists ruler <- Deriver Marklists get_ruler -- let ruler = mempty State state <- forall st err. Deriver st err st get -- Debug.traceM "get_control_function_dynamic" () forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Marklists -> Dynamic -> Serial -> Dynamic convert_dynamic Marklists ruler (State -> Dynamic state_dynamic State state) (Threaded -> Serial state_event_serial (State -> Threaded state_threaded State state)) convert_dynamic :: Ruler.Marklists -> Dynamic -> Stack.Serial -> DeriveT.Dynamic convert_dynamic :: Marklists -> Dynamic -> Serial -> Dynamic convert_dynamic Marklists ruler Dynamic dyn Serial serial = DeriveT.Dynamic { dyn_pitch :: PSignal dyn_pitch = Dynamic -> PSignal state_pitch Dynamic dyn , dyn_environ :: Environ dyn_environ = Dynamic -> Environ state_environ Dynamic dyn , dyn_event_serial :: Serial dyn_event_serial = Serial serial , dyn_warp :: Warp dyn_warp = Dynamic -> Warp state_warp Dynamic dyn , dyn_ruler :: Marklists dyn_ruler = Marklists ruler } -- | Get the 'Ruler.meter' marklists, if there is a ruler track here. This -- is called in all contexts, due to 'control_at', so it has to be careful -- to not require a ruler. get_ruler :: Deriver Ruler.Marklists get_ruler :: Deriver Marklists get_ruler = Deriver (Maybe (BlockId, Serial)) lookup_current_tracknum forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Maybe (BlockId, Serial) Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Monoid a => a mempty Just (BlockId block_id, Serial tracknum) -> do State state <- forall a. (State -> a) -> Deriver a get_ui_state forall a. a -> a id forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a b. a -> b -> a const forall a. Monoid a => a mempty) forall a. a -> a id forall a b. (a -> b) -> a -> b $ forall a. State -> StateId a -> Either Error a Ui.eval State state forall a b. (a -> b) -> a -> b $ do RulerId ruler_id <- forall a. a -> Maybe a -> a fromMaybe RulerId Ui.no_ruler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> Serial -> m (Maybe RulerId) Ui.ruler_track_at BlockId block_id Serial tracknum Ruler -> Marklists Ruler.ruler_marklists forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => RulerId -> m Ruler Ui.get_ruler RulerId ruler_id -- * Threaded modify_threaded :: (Threaded -> Threaded) -> Deriver () modify_threaded :: (Threaded -> Threaded) -> Deriver State Error () modify_threaded Threaded -> Threaded f = forall st err. (st -> st) -> Deriver st err () modify forall a b. (a -> b) -> a -> b $ \State state -> State state { state_threaded :: Threaded state_threaded = Threaded -> Threaded f (State -> Threaded state_threaded State state) } -- | Increment 'state_event_serial'. increment_event_serial :: Deriver () increment_event_serial :: Deriver State Error () increment_event_serial = (Threaded -> Threaded) -> Deriver State Error () modify_threaded forall a b. (a -> b) -> a -> b $ \Threaded threaded -> Threaded threaded { state_event_serial :: Serial state_event_serial = Threaded -> Serial state_event_serial Threaded threaded forall a. Num a => a -> a -> a + Serial 1 } -- * misc -- | Am I deriving the toplevel block? is_root_block :: Deriver Bool is_root_block :: Deriver Bool is_root_block = Stack -> Bool is_root_block_stack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Deriver Stack get_stack where is_root_block_stack :: Stack -> Bool is_root_block_stack Stack stack = case [BlockId bid | Stack.Block BlockId bid <- Stack -> [Frame] Stack.outermost Stack stack] of [] -> Bool True [BlockId _] -> Bool True [BlockId] _ -> Bool False