-- 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.PSignal as PSignal 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 = (State -> a) -> Deriver State Error a forall st a err. (st -> a) -> Deriver st err a gets (Dynamic -> a f (Dynamic -> a) -> (State -> Dynamic) -> State -> a 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 = (State -> a) -> Deriver State Error a forall st a err. (st -> a) -> Deriver st err a gets (Constant -> a f (Constant -> a) -> (State -> Constant) -> State -> a 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 = (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a localm (Dynamic -> Deriver Dynamic forall (m :: * -> *) a. Monad m => a -> m a return (Dynamic -> Deriver Dynamic) -> (Dynamic -> Dynamic) -> Dynamic -> Deriver Dynamic 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 <- Deriver State Error State forall st err. Deriver st err st get Dynamic new <- Dynamic -> Deriver Dynamic modify_dynamic (State -> Dynamic state_dynamic State st) State -> Deriver State Error () forall st err. st -> Deriver st err () put (State -> Deriver State Error ()) -> State -> Deriver State Error () forall a b. (a -> b) -> a -> b $ State st { state_dynamic :: Dynamic state_dynamic = Dynamic new } a result <- Deriver a deriver (State -> State) -> Deriver State Error () forall st err. (st -> st) -> Deriver st err () modify ((State -> State) -> Deriver State Error ()) -> (State -> State) -> Deriver State Error () forall a b. (a -> b) -> a -> b $ \State new -> State new { state_dynamic :: Dynamic state_dynamic = State -> Dynamic state_dynamic State st } a -> Deriver a 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 <- Deriver State Error State forall st err. Deriver st err st get let (Either Error a result, State _, [Msg] logs) = State -> Deriver a -> (Either Error a, State, [Msg]) 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 (Msg -> Deriver State Error ()) -> [Msg] -> Deriver State Error () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ Msg -> Deriver State Error () forall (m :: * -> *). LogMonad m => Msg -> m () Log.write [Msg] logs Either Error a -> Deriver (Either Error a) 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 = (State -> State) -> Deriver State Error () forall st err. (st -> st) -> Deriver st err () modify ((State -> State) -> Deriver State Error ()) -> (State -> State) -> Deriver State Error () forall a b. (a -> b) -> a -> b $ \State st -> State st { state_threaded :: Threaded state_threaded = Threaded threaded } get_named_pitch :: ScoreT.PControl -> Deriver (Maybe PSignal.PSignal) get_named_pitch :: PControl -> Deriver (Maybe PSignal) get_named_pitch PControl name | PControl name PControl -> PControl -> Bool forall a. Eq a => a -> a -> Bool == PControl ScoreT.default_pitch = PSignal -> Maybe PSignal forall a. a -> Maybe a Just (PSignal -> Maybe PSignal) -> Deriver State Error PSignal -> Deriver (Maybe PSignal) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Dynamic -> PSignal) -> Deriver State Error PSignal forall a. (Dynamic -> a) -> Deriver a get_dynamic Dynamic -> PSignal state_pitch | Bool otherwise = PControl -> Map PControl PSignal -> Maybe PSignal forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup PControl name (Map PControl PSignal -> Maybe PSignal) -> Deriver State Error (Map PControl PSignal) -> Deriver (Maybe PSignal) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Dynamic -> Map PControl PSignal) -> Deriver State Error (Map PControl PSignal) forall a. (Dynamic -> a) -> Deriver a get_dynamic Dynamic -> Map PControl PSignal state_pitches -- * 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 = (State -> State) -> Deriver State Error () forall st err. (st -> st) -> Deriver st err () modify ((State -> State) -> Deriver State Error ()) -> (State -> State) -> Deriver State Error () forall a b. (a -> b) -> a -> b $ \State st -> State st { state_collect :: Collect state_collect = State -> Collect state_collect State st Collect -> Collect -> Collect 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 <- (State -> Collect) -> Deriver State Error Collect forall st a err. (st -> a) -> Deriver st err a gets State -> Collect state_collect (State -> State) -> Deriver State Error () forall st err. (st -> st) -> Deriver st err () modify ((State -> State) -> Deriver State Error ()) -> (State -> State) -> Deriver State Error () forall a b. (a -> b) -> a -> b $ \State st -> State st { state_collect :: Collect state_collect = Collect forall a. Monoid a => a mempty } a result <- Deriver a deriver Collect sub_collect <- (State -> Collect) -> Deriver State Error Collect forall st a err. (st -> a) -> Deriver st err a gets State -> Collect state_collect (State -> State) -> Deriver State Error () forall st err. (st -> st) -> Deriver st err () modify ((State -> State) -> Deriver State Error ()) -> (State -> State) -> Deriver State Error () forall a b. (a -> b) -> a -> b $ \State st -> State st { state_collect :: Collect state_collect = Collect old } (a, Collect) -> Deriver (a, Collect) 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 = (Collect -> Collect) -> Deriver a -> Deriver a forall a. (Collect -> Collect) -> Deriver a -> Deriver a with_collect ((Collect -> Collect) -> Deriver a -> Deriver a) -> (Collect -> Collect) -> Deriver a -> Deriver a forall a b. (a -> b) -> a -> b $ \Collect st -> Collect st { collect_warp_map :: WarpMap collect_warp_map = Track -> Track trim (Track -> Track) -> WarpMap -> WarpMap 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 (RealTime -> (RealTime -> RealTime) -> Maybe RealTime -> RealTime forall b a. b -> (a -> b) -> Maybe a -> b maybe RealTime s (RealTime -> RealTime -> RealTime forall a. Ord a => a -> a -> a max RealTime s) Maybe RealTime start) (RealTime -> (RealTime -> RealTime) -> Maybe RealTime -> RealTime forall b a. b -> (a -> b) -> Maybe a -> b maybe RealTime e (RealTime -> RealTime -> RealTime 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) <- Deriver a -> Deriver (a, Collect) forall a. Deriver a -> Deriver (a, Collect) local_collect Deriver a deriver Collect -> Deriver State Error () merge_collect (Collect -> Collect modify Collect collect) a -> Deriver a 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 = (State -> State) -> Deriver State Error () forall st err. (st -> st) -> Deriver st err () modify ((State -> State) -> Deriver State Error ()) -> (State -> State) -> Deriver State Error () 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 = (Dynamic -> Environ) -> Deriver 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) -> TrackDynamic -> Maybe TrackDynamic forall a. a -> Maybe a Just (TrackDynamic -> Maybe TrackDynamic) -> TrackDynamic -> Maybe TrackDynamic forall a b. (a -> b) -> a -> b $! (BlockId, TrackId) -> Dynamic -> TrackDynamic forall k a. k -> a -> Map k a Map.singleton (BlockId bid, TrackId tid) (Dynamic -> TrackDynamic) -> Dynamic -> TrackDynamic 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 -> Maybe TrackDynamic 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 <- (State -> Dynamic) -> Deriver Dynamic forall st a err. (st -> a) -> Deriver st err a gets State -> Dynamic state_dynamic Collect -> Deriver State Error () merge_collect (Collect -> Deriver State Error ()) -> Collect -> Deriver State Error () forall a b. (a -> b) -> a -> b $ Collect forall a. Monoid a => a mempty { collect_track_dynamic :: TrackDynamic collect_track_dynamic = (BlockId, TrackId) -> Dynamic -> TrackDynamic 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 = (Dynamic -> Dynamic) -> Deriver a -> Deriver a forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a) -> (Dynamic -> Dynamic) -> Deriver a -> Deriver a 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 Map Control Merger -> Map Control Merger -> Map Control Merger 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 = (Dynamic -> Dynamic) -> Deriver derived -> Deriver derived forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a local ((Dynamic -> Dynamic) -> Deriver derived -> Deriver derived) -> (Dynamic -> Dynamic) -> Deriver derived -> Deriver derived 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 (Collect -> Deriver State Error ()) -> Collect -> Deriver State Error () forall a b. (a -> b) -> a -> b $ Collect forall a. Monoid a => a mempty { collect_block_deps :: BlockDeps collect_block_deps = Set BlockId -> BlockDeps BlockDeps (BlockId -> Set BlockId 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 = (State -> a) -> Deriver State Error a forall st a err. (st -> a) -> Deriver st err a gets (State -> a f (State -> a) -> (State -> State) -> State -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Constant -> State state_ui (Constant -> State) -> (State -> Constant) -> State -> State 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 = (State -> a) -> Deriver a forall a. (State -> a) -> Deriver a get_ui_state (Config -> a f (Config -> a) -> (State -> Config) -> State -> a 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 = TrackId -> Map TrackId Track -> Deriver Track forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a lookup_id TrackId track_id (Map TrackId Track -> Deriver Track) -> Deriver State Error (Map TrackId Track) -> Deriver Track forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< (State -> Map TrackId Track) -> Deriver State Error (Map TrackId Track) 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 = BlockId -> Map BlockId Block -> Deriver Block forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a lookup_id BlockId block_id (Map BlockId Block -> Deriver Block) -> Deriver State Error (Map BlockId Block) -> Deriver Block forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< (State -> Map BlockId Block) -> Deriver State Error (Map BlockId Block) 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 <- (State -> State) -> Deriver State forall a. (State -> a) -> Deriver a get_ui_state State -> State forall a. a -> a id let rethrow :: a -> Deriver a rethrow a exc = Text -> Deriver a forall a. Stack => Text -> Deriver a throw (Text -> Deriver a) -> Text -> Deriver a forall a b. (a -> b) -> a -> b $ a -> Text forall a. Pretty a => a -> Text pretty a exc (Error -> Deriver a) -> (a -> Deriver a) -> Either Error a -> Deriver a forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either Error -> Deriver a forall {a} {a}. Pretty a => a -> Deriver a rethrow a -> Deriver a forall (m :: * -> *) a. Monad m => a -> m a return (State -> StateId a -> Either Error a 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 k -> Map k a -> Maybe a forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup k key Map k a map of Maybe a Nothing -> Text -> Deriver a forall a. Stack => Text -> Deriver a throw (Text -> Deriver a) -> Text -> Deriver a forall a b. (a -> b) -> a -> b $ Text "unknown " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> k -> Text forall a. Show a => a -> Text showt k key Just a val -> a -> Deriver a 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 Maybe BlockId -> Deriver (Maybe BlockId) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe BlockId -> Deriver (Maybe BlockId)) -> Maybe BlockId -> Deriver (Maybe BlockId) forall a b. (a -> b) -> a -> b $ case [BlockId bid | Stack.Block BlockId bid <- Stack -> [Frame] Stack.innermost Stack stack] of [] -> Maybe BlockId forall a. Maybe a Nothing BlockId bid : [BlockId] _ -> BlockId -> Maybe 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 = Deriver BlockId -> (BlockId -> Deriver BlockId) -> Maybe BlockId -> Deriver BlockId forall b a. b -> (a -> b) -> Maybe a -> b maybe (Text -> Deriver BlockId forall a. Stack => Text -> Deriver a throw Text "get_current_block_id: no blocks in stack") BlockId -> Deriver BlockId forall (m :: * -> *) a. Monad m => a -> m a return (Maybe BlockId -> Deriver BlockId) -> Deriver (Maybe BlockId) -> Deriver BlockId 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 -> Maybe (BlockId, Serial) -> Deriver (Maybe (BlockId, Serial)) forall (m :: * -> *) a. Monad m => a -> m a return Maybe (BlockId, Serial) forall a. Maybe a Nothing Just (BlockId block_id, TrackId track_id) -> do Serial tracknum <- StateId Serial -> Deriver Serial forall a. Stack => StateId a -> Deriver a eval_ui (StateId Serial -> Deriver Serial) -> StateId Serial -> Deriver Serial forall a b. (a -> b) -> a -> b $ BlockId -> TrackId -> StateId Serial forall (m :: * -> *). M m => BlockId -> TrackId -> m Serial Ui.get_tracknum_of BlockId block_id TrackId track_id Maybe (BlockId, Serial) -> Deriver (Maybe (BlockId, Serial)) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe (BlockId, Serial) -> Deriver (Maybe (BlockId, Serial))) -> Maybe (BlockId, Serial) -> Deriver (Maybe (BlockId, Serial)) forall a b. (a -> b) -> a -> b $ (BlockId, Serial) -> Maybe (BlockId, Serial) 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 = Deriver (BlockId, Serial) -> ((BlockId, Serial) -> Deriver (BlockId, Serial)) -> Maybe (BlockId, Serial) -> Deriver (BlockId, Serial) forall b a. b -> (a -> b) -> Maybe a -> b maybe (Text -> Deriver (BlockId, Serial) forall a. Stack => Text -> Deriver a throw Text "get_current_tracknum") (BlockId, Serial) -> Deriver (BlockId, Serial) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe (BlockId, Serial) -> Deriver (BlockId, Serial)) -> Deriver (Maybe (BlockId, Serial)) -> Deriver (BlockId, Serial) 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 = Frame -> Deriver a -> Deriver a forall a. Frame -> Deriver a -> Deriver a with_stack (Frame -> Deriver a -> Deriver a) -> (BlockId -> Frame) -> BlockId -> Deriver a -> Deriver a 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 = Frame -> Deriver a -> Deriver a forall a. Frame -> Deriver a -> Deriver a with_stack (Frame -> Deriver a -> Deriver a) -> (TrackId -> Frame) -> TrackId -> Deriver a -> Deriver a 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 = Frame -> Deriver a -> Deriver a 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) = Frame -> Deriver a -> Deriver a 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 = Frame -> Deriver a -> Deriver a forall a. Frame -> Deriver a -> Deriver a with_stack (Frame -> Deriver a -> Deriver a) -> (Serial -> Frame) -> Serial -> Deriver a -> Deriver a 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 = (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a localm ((Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a) -> (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a forall a b. (a -> b) -> a -> b $ \Dynamic st -> do Stack stack <- Deriver Stack get_stack Bool -> Deriver State Error () -> Deriver State Error () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Stack -> Serial Stack.length Stack stack Serial -> Serial -> Bool forall a. Ord a => a -> a -> Bool >= Serial max_depth) (Deriver State Error () -> Deriver State Error ()) -> Deriver State Error () -> Deriver State Error () forall a b. (a -> b) -> a -> b $ Text -> Deriver State Error () forall a. Stack => Text -> Deriver a throw (Text -> Deriver State Error ()) -> Text -> Deriver State Error () forall a b. (a -> b) -> a -> b $ Text "call stack too deep: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Frame -> Text forall a. Pretty a => a -> Text pretty Frame frame Dynamic -> Deriver Dynamic forall (m :: * -> *) a. Monad m => a -> m a return (Dynamic -> Deriver Dynamic) -> Dynamic -> Deriver Dynamic 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 Environ -> Environ 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 (Typed Double -> Val DeriveT.VNum (Double -> Typed Double forall a. a -> Typed a ScoreT.untyped (Double -> Double update Double old))) Environ env where old :: Double old = case Text -> Environ -> Maybe Val DeriveT.lookup Text EnvKey.seed Environ env of Just (DeriveT.VNum Typed Double n) -> Typed Double -> Double forall a. Typed a -> a ScoreT.typed_val Typed Double n Maybe Val _ -> Double 0 update :: Double -> Double update :: Double -> Double update Double n = Serial -> Double i2d (Serial -> Frame -> Serial forall a. Seed a => Serial -> a -> Serial Seed.to_seed (Double -> Serial 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 = Serial -> Double forall a b. (Integral a, Num b) => a -> b fromIntegral (Serial i Serial -> Serial -> Serial forall a. Integral a => a -> a -> a `mod` Serial 999) get_stack :: Deriver Stack.Stack get_stack :: Deriver Stack get_stack = (Dynamic -> Stack) -> Deriver 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 = ScoreTime -> Deriver ScoreTime 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 = RealTime -> Deriver RealTime 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) = RealTime -> Deriver RealTime forall a. Time a => a -> Deriver RealTime real RealTime t real (DeriveT.ScoreDuration ScoreTime t) = ScoreTime -> Deriver RealTime forall a. Time a => a -> Deriver RealTime real ScoreTime t score :: Duration -> Deriver ScoreTime score (DeriveT.RealDuration RealTime t) = RealTime -> Deriver ScoreTime forall a. Time a => a -> Deriver ScoreTime score RealTime t score (DeriveT.ScoreDuration ScoreTime t) = ScoreTime -> Deriver ScoreTime forall a. Time a => a -> Deriver ScoreTime score ScoreTime t to_duration :: Duration -> Duration to_duration = Duration -> 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 = (Warp -> Warp) -> Deriver a -> Deriver a forall a. (Warp -> Warp) -> Deriver a -> Deriver a with_warp (Warp -> Warp -> 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 = (Dynamic -> Dynamic) -> Deriver a -> Deriver a forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a) -> (Dynamic -> Dynamic) -> Deriver a -> Deriver a 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 = (Dynamic -> Warp) -> Deriver 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 = (Warp -> Warp) -> Deriver a -> Deriver a forall a. (Warp -> Warp) -> Deriver a -> Deriver a with_warp ((Warp -> Warp) -> Deriver a -> Deriver a) -> (Warp -> Warp) -> Deriver a -> Deriver a 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 = (Warp -> Warp) -> Deriver a -> Deriver a forall a. (Warp -> Warp) -> Deriver a -> Deriver a with_warp ((Warp -> Warp) -> Deriver a -> Deriver a) -> (Warp -> Warp) -> Deriver a -> Deriver a 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 = (Warp -> Warp) -> Deriver a -> Deriver a forall a. (Warp -> Warp) -> Deriver a -> Deriver a with_warp ((Warp -> Warp) -> Deriver a -> Deriver a) -> (Warp -> Warp) -> Deriver a -> Deriver a forall a b. (a -> b) -> a -> b $ ScoreTime -> Warp -> Warp Warp.stretch ScoreTime stretch (Warp -> Warp) -> (Warp -> Warp) -> Warp -> Warp 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 = Deriver a -> Deriver a forall a. a -> a id | Bool otherwise = (Warp -> Warp) -> Deriver a -> Deriver a 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 <- ScoreTime -> Deriver RealTime forall a. Time a => a -> Deriver RealTime real (ScoreTime -> Deriver RealTime) -> Deriver ScoreTime -> Deriver RealTime 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 (Collect -> Deriver State Error ()) -> Collect -> Deriver State Error () forall a b. (a -> b) -> a -> b $ Collect forall a. Monoid a => a mempty { collect_warp_map :: WarpMap collect_warp_map = Stack -> Track -> WarpMap 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 = StateId (ScoreTime, ScoreTime) -> Deriver (ScoreTime, ScoreTime) forall a. Stack => StateId a -> Deriver a eval_ui (StateId (ScoreTime, ScoreTime) -> Deriver (ScoreTime, ScoreTime)) -> (BlockId -> StateId (ScoreTime, ScoreTime)) -> BlockId -> Deriver (ScoreTime, ScoreTime) forall b c a. (b -> c) -> (a -> b) -> a -> c . BlockId -> StateId (ScoreTime, ScoreTime) 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 = StateId ScoreTime -> Deriver ScoreTime forall a. Stack => StateId a -> Deriver a eval_ui (StateId ScoreTime -> Deriver ScoreTime) -> (BlockId -> StateId ScoreTime) -> BlockId -> Deriver ScoreTime forall b c a. (b -> c) -> (a -> b) -> a -> c . BlockId -> StateId ScoreTime 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 [] = () -> Deriver State Error () 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 (TrackId -> Deriver State Error ()) -> [TrackId] -> Deriver State Error () 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 get_control_function_dynamic :: Deriver DeriveT.Dynamic get_control_function_dynamic :: Deriver Dynamic get_control_function_dynamic = do Marklists ruler <- Deriver Marklists get_ruler State state <- Deriver State Error State forall st err. Deriver st err st get Dynamic -> Deriver Dynamic forall (m :: * -> *) a. Monad m => a -> m a return (Dynamic -> Deriver Dynamic) -> Dynamic -> Deriver Dynamic 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_controls :: ControlMap dyn_controls = Dynamic -> ControlMap state_controls Dynamic dyn , dyn_control_functions :: ControlFunctionMap dyn_control_functions = Dynamic -> ControlFunctionMap state_control_functions Dynamic dyn , dyn_pitches :: Map PControl PSignal dyn_pitches = Dynamic -> Map PControl PSignal state_pitches Dynamic dyn , 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 Deriver (Maybe (BlockId, Serial)) -> (Maybe (BlockId, Serial) -> Deriver Marklists) -> Deriver Marklists forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Maybe (BlockId, Serial) Nothing -> Marklists -> Deriver Marklists forall (m :: * -> *) a. Monad m => a -> m a return Marklists forall a. Monoid a => a mempty Just (BlockId block_id, Serial tracknum) -> do State state <- (State -> State) -> Deriver State forall a. (State -> a) -> Deriver a get_ui_state State -> State forall a. a -> a id Marklists -> Deriver Marklists forall (m :: * -> *) a. Monad m => a -> m a return (Marklists -> Deriver Marklists) -> Marklists -> Deriver Marklists forall a b. (a -> b) -> a -> b $ (Error -> Marklists) -> (Marklists -> Marklists) -> Either Error Marklists -> Marklists forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (Marklists -> Error -> Marklists forall a b. a -> b -> a const Marklists forall a. Monoid a => a mempty) Marklists -> Marklists forall a. a -> a id (Either Error Marklists -> Marklists) -> Either Error Marklists -> Marklists forall a b. (a -> b) -> a -> b $ State -> StateId Marklists -> Either Error Marklists forall a. State -> StateId a -> Either Error a Ui.eval State state (StateId Marklists -> Either Error Marklists) -> StateId Marklists -> Either Error Marklists forall a b. (a -> b) -> a -> b $ do RulerId ruler_id <- RulerId -> Maybe RulerId -> RulerId forall a. a -> Maybe a -> a fromMaybe RulerId Ui.no_ruler (Maybe RulerId -> RulerId) -> StateT Identity (Maybe RulerId) -> StateT Identity RulerId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> BlockId -> Serial -> StateT Identity (Maybe RulerId) forall (m :: * -> *). M m => BlockId -> Serial -> m (Maybe RulerId) Ui.ruler_track_at BlockId block_id Serial tracknum Ruler -> Marklists Ruler.ruler_marklists (Ruler -> Marklists) -> StateT Identity Ruler -> StateId Marklists forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RulerId -> StateT Identity Ruler 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 = (State -> State) -> Deriver State Error () forall st err. (st -> st) -> Deriver st err () modify ((State -> State) -> Deriver State Error ()) -> (State -> State) -> Deriver State Error () 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 ((Threaded -> Threaded) -> Deriver State Error ()) -> (Threaded -> Threaded) -> Deriver State Error () 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 Serial -> Serial -> Serial 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 = do Stack stack <- Deriver Stack get_stack let blocks :: [BlockId] blocks = [BlockId bid | Stack.Block BlockId bid <- Stack -> [Frame] Stack.outermost Stack stack] Bool -> Deriver Bool forall (m :: * -> *) a. Monad m => a -> m a return (Bool -> Deriver Bool) -> Bool -> Deriver Bool forall a b. (a -> b) -> a -> b $ case [BlockId] blocks of [] -> Bool True [BlockId _] -> Bool True [BlockId] _ -> Bool False