-- Copyright 2013 Evan Laforge -- This program is distributed under the terms of the GNU General Public -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt {-# LANGUAGE CPP #-} module Derive.Cache ( Cacheable(..) , block, track , get_control_damage, get_tempo_damage , is_cache_log, cache_hit_events, cache_miss_reason -- * debugging , pretty_cache #ifdef TESTING , find_generator_cache , _extend_control_damage #endif ) where import qualified Data.Map.Strict as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.Text as Text import qualified Util.Lists as Lists import qualified Util.Log as Log import qualified Util.Ranges as Ranges import qualified Derive.Args as Args import qualified Derive.Derive as Derive import Derive.Derive (Cache(..), Cached(..), ControlDamage(..), ScoreDamage(..)) import qualified Derive.Deriver.Internal as Internal import qualified Derive.LEvent as LEvent import qualified Derive.PSignal as PSignal import qualified Derive.Score as Score import qualified Derive.Stack as Stack import qualified Derive.Stream as Stream 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 class Cacheable d where from_cache_entry :: Derive.CacheEntry -> Maybe (Derive.CallType d) to_cache_entry :: Derive.CallType d -> Derive.CacheEntry instance Cacheable Score.Event where from_cache_entry :: CacheEntry -> Maybe (CallType Event) from_cache_entry (Derive.CachedEvents CallType Event ctype) = forall a. a -> Maybe a Just CallType Event ctype from_cache_entry CacheEntry _ = forall a. Maybe a Nothing to_cache_entry :: CallType Event -> CacheEntry to_cache_entry = CallType Event -> CacheEntry Derive.CachedEvents instance Cacheable Signal.Control where from_cache_entry :: CacheEntry -> Maybe (CallType Control) from_cache_entry (Derive.CachedControl CallType Control ctype) = forall a. a -> Maybe a Just CallType Control ctype from_cache_entry CacheEntry _ = forall a. Maybe a Nothing to_cache_entry :: CallType Control -> CacheEntry to_cache_entry = CallType Control -> CacheEntry Derive.CachedControl instance Cacheable PSignal.PSignal where from_cache_entry :: CacheEntry -> Maybe (CallType PSignal) from_cache_entry (Derive.CachedPitch CallType PSignal ctype) = forall a. a -> Maybe a Just CallType PSignal ctype from_cache_entry CacheEntry _ = forall a. Maybe a Nothing to_cache_entry :: CallType PSignal -> CacheEntry to_cache_entry = CallType PSignal -> CacheEntry Derive.CachedPitch -- * block -- | Unfortunately caching is not entirely general, and cache invalidation -- works a bit differently for blocks and tracks. data Type = Block !BlockId -- | Cache a track. For a note track, the set is its TrackId along with -- its children, so it knows what sort of damage will invalidate the cache. -- If the track has children, it's assumed to be inverting, so that it -- depends on all of its children. For a control track, the set should be -- empty, since control tracks are not invalidated by damage on their -- children. | Track !TrackId !(Set TrackId) deriving (Type -> Type -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Type -> Type -> Bool $c/= :: Type -> Type -> Bool == :: Type -> Type -> Bool $c== :: Type -> Type -> Bool Eq, Int -> Type -> ShowS [Type] -> ShowS Type -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Type] -> ShowS $cshowList :: [Type] -> ShowS show :: Type -> String $cshow :: Type -> String showsPrec :: Int -> Type -> ShowS $cshowsPrec :: Int -> Type -> ShowS Show) -- | If the given generator has a cache entry, relevant derivation context is -- the same as the cache entry's, and there is no damage under the generator, -- I can reuse the cached values for it. This is effectively a kind of -- memoization. If the generator is called, the results will be put in the -- cache before being returned. block :: BlockId -> (Derive.PassedArgs d -> Derive.NoteDeriver) -> (Derive.PassedArgs d -> Derive.NoteDeriver) block :: forall d. BlockId -> (PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver block BlockId block_id PassedArgs d -> NoteDeriver call PassedArgs d args = forall d. Cacheable d => Type -> Range -> Deriver (Stream d) -> Deriver (Stream d) caching_deriver (BlockId -> Type Block BlockId block_id) Range range (PassedArgs d -> NoteDeriver call PassedArgs d args) where range :: Range range = Range { _start :: ScoreTime _start = forall a b. (a, b) -> a fst forall a b. (a -> b) -> a -> b $ forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_on_track PassedArgs d args , _end :: ScoreTime _end = forall a b. (a, b) -> b snd forall a b. (a -> b) -> a -> b $ forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_on_track PassedArgs d args , _negative :: Bool _negative = Event -> Bool Event.is_negative (forall a. PassedArgs a -> Event Args.event PassedArgs d args) } data Range = Range { Range -> ScoreTime _start :: !TrackTime , Range -> ScoreTime _end :: !TrackTime -- | If True, these are the ranges of a negative event, which affects how -- control damage works. , Range -> Bool _negative :: !Bool } deriving (Int -> Range -> ShowS [Range] -> ShowS Range -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Range] -> ShowS $cshowList :: [Range] -> ShowS show :: Range -> String $cshow :: Range -> String showsPrec :: Int -> Range -> ShowS $cshowsPrec :: Int -> Range -> ShowS Show) -- | Cache a track, but only if it's not sliced and has a TrackId. track :: Cacheable d => TrackTree.Track -> Set TrackId -- ^ Children, as documented in 'Track'. -> Derive.Deriver (Stream.Stream d) -> Derive.Deriver (Stream.Stream d) track :: forall d. Cacheable d => Track -> Set TrackId -> Deriver (Stream d) -> Deriver (Stream d) track Track track Set TrackId children Deriver (Stream d) deriver = case Track -> Maybe TrackId should_cache Track track of Just TrackId track_id -> forall d. Cacheable d => Type -> Range -> Deriver (Stream d) -> Deriver (Stream d) caching_deriver (TrackId -> Set TrackId -> Type Track TrackId track_id Set TrackId children) Range range Deriver (Stream d) deriver Maybe TrackId Nothing -> Deriver (Stream d) deriver where range :: Range range = Range { _start :: ScoreTime _start = Track -> ScoreTime TrackTree.track_start Track track , _end :: ScoreTime _end = Track -> ScoreTime TrackTree.track_end Track track , _negative :: Bool _negative = Bool False } should_cache :: TrackTree.Track -> Maybe TrackId should_cache :: Track -> Maybe TrackId should_cache Track track | Track -> Sliced TrackTree.track_sliced Track track forall a. Eq a => a -> a -> Bool == Sliced TrackTree.NotSliced = Track -> Maybe TrackId TrackTree.track_id Track track | Bool otherwise = forall a. Maybe a Nothing caching_deriver :: Cacheable d => Type -> Range -> Derive.Deriver (Stream.Stream d) -> Derive.Deriver (Stream.Stream d) caching_deriver :: forall d. Cacheable d => Type -> Range -> Deriver (Stream d) -> Deriver (Stream d) caching_deriver Type typ Range range Deriver (Stream d) call = do State st <- forall st err. Deriver st err st Derive.get let cdamage :: ControlDamage cdamage = Dynamic -> ControlDamage Derive.state_control_damage (State -> Dynamic Derive.state_dynamic State st) sdamage :: ScoreDamage sdamage = Constant -> ScoreDamage Derive.state_score_damage (State -> Constant Derive.state_constant State st) stack :: Stack stack = Dynamic -> Stack Derive.state_stack (State -> Dynamic Derive.state_dynamic State st) Stack -> Either (Bool, Text) (Collect, Stream d) -> Deriver (Stream d) generate Stack stack forall a b. (a -> b) -> a -> b $ forall d. Cacheable d => Type -> CacheKey -> Range -> ScoreDamage -> ControlDamage -> Cache -> Either (Bool, Text) (Collect, Stream d) find_generator_cache Type typ (Stack -> CacheKey Derive.CacheKey Stack stack) Range range ScoreDamage sdamage ControlDamage cdamage (Constant -> Cache Derive.state_cache (State -> Constant Derive.state_constant State st)) where generate :: Stack -> Either (Bool, Text) (Collect, Stream d) -> Deriver (Stream d) generate Stack _ (Right (Collect collect, Stream d cached)) = do forall (m :: * -> *). LogMonad m => Msg -> m () Log.write forall a b. (a -> b) -> a -> b $ forall a. Stream a -> Msg cache_hit_msg Stream d cached CacheStats stats <- Type -> Range -> Deriver CacheStats hit_stats Type typ Range range -- The cached deriver must return the same collect as it would if it -- had been actually derived. Collect -> Deriver State Error () Internal.merge_collect forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { collect_cache_stats :: CacheStats Derive.collect_cache_stats = CacheStats stats } forall a. Semigroup a => a -> a -> a <> Collect collect forall (m :: * -> *) a. Monad m => a -> m a return Stream d cached generate Stack stack (Left (Bool inflict_control_damage, Text reason)) = do (Stream d result, Collect collect) <- forall {a}. Bool -> Deriver a -> Deriver State Error (a, Collect) with_collect Bool inflict_control_damage Deriver (Stream d) call forall (m :: * -> *). LogMonad m => Msg -> m () Log.write forall a b. (a -> b) -> a -> b $ Text -> Msg cache_miss_msg Text reason Collect -> Deriver State Error () Internal.merge_collect forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { collect_cache :: Cache Derive.collect_cache = forall d. Cacheable d => CacheKey -> Collect -> Stream d -> Cache make_cache (Stack -> CacheKey Derive.CacheKey Stack stack) Collect collect Stream d result } forall (m :: * -> *) a. Monad m => a -> m a return Stream d result -- To get the deps of just the deriver below me, I have to clear out -- the local deps. But this call is itself collecting deps for another -- call, so I have to merge the sub-deps back in before returning. with_collect :: Bool -> Deriver a -> Deriver State Error (a, Collect) with_collect Bool inflict_control_damage Deriver a deriver = do -- TODO Do I want to run deriver a sub derivation so I can put an -- empty cache if it failed? Otherwise I think maybe a failed -- event will continue to produce its old value. (a result, Collect collect) <- forall {a}. Bool -> Deriver a -> Deriver State Error (a, Collect) with_empty_collect (Type -> Bool is_block Type typ Bool -> Bool -> Bool && Bool inflict_control_damage) Deriver a deriver Collect -> Deriver State Error () Internal.merge_collect Collect collect forall (m :: * -> *) a. Monad m => a -> m a return (a result, Collect collect) is_block :: Type -> Bool is_block (Block {}) = Bool True is_block Type _ = Bool False hit_stats :: Type -> Range -> Derive.Deriver Derive.CacheStats hit_stats :: Type -> Range -> Deriver CacheStats hit_stats Type typ (Range ScoreTime start ScoreTime end Bool _) = do RealTime start <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime start RealTime end <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime end forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { cstats_hits :: [(Either BlockId TrackId, (RealTime, RealTime))] Derive.cstats_hits = [(Either BlockId TrackId id, (RealTime start, RealTime end))] } where id :: Either BlockId TrackId id = case Type typ of Block BlockId block_id -> forall a b. a -> Either a b Left BlockId block_id Track TrackId track_id Set TrackId _ -> forall a b. b -> Either a b Right TrackId track_id -- real_range :: Ranges.Ranges ScoreTime -> Derive.Deriver (RealTime, RealTime) -- real_range ranges = case Ranges.extract ranges of -- undefined -- | Both track warps and local deps are used as dynamic return values (aka -- modifying a variable to \"return\" something). When evaluating a cached -- generator, the caller wants to know the callee's track warps and local -- deps, without getting them mixed up with its own warps and deps. So run -- a deriver in an empty environment, and restore it afterwards. with_empty_collect :: Bool -- ^ If True, expand the ControlDamage to Ranges.everything. If -- ControlDamage touches a block call then it likely invalidates everything -- within that block. -> Derive.Deriver a -> Derive.Deriver (a, Derive.Collect) with_empty_collect :: forall {a}. Bool -> Deriver a -> Deriver State Error (a, Collect) with_empty_collect Bool inflict_control_damage Deriver a deriver = do State old <- forall st err. Deriver st err st Derive.get forall st err. (st -> st) -> Deriver st err () Derive.modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_collect :: Collect Derive.state_collect = forall a. Monoid a => a mempty , state_dynamic :: Dynamic Derive.state_dynamic = if Bool inflict_control_damage then (State -> Dynamic Derive.state_dynamic State st) { state_control_damage :: ControlDamage Derive.state_control_damage = Ranges ScoreTime -> ControlDamage Derive.ControlDamage forall n. Ranges n Ranges.everything } else State -> Dynamic Derive.state_dynamic State st } a result <- Deriver a deriver Collect collect <- forall st a err. (st -> a) -> Deriver st err a Derive.gets State -> Collect Derive.state_collect forall st err. st -> Deriver st err () Derive.put State old forall (m :: * -> *) a. Monad m => a -> m a return (a result, Collect collect) -- | Find the cached value, or a reason why there is no cache entry. This -- is the function that determines whether you hit the cache or not. find_generator_cache :: Cacheable d => Type -> Derive.CacheKey -> Range -> ScoreDamage -> ControlDamage -> Cache -> Either (Bool, Text) (Derive.Collect, Stream.Stream d) -- ^ on a miss, the Bool is 'with_empty_collect's inflict_control_damage arg find_generator_cache :: forall d. Cacheable d => Type -> CacheKey -> Range -> ScoreDamage -> ControlDamage -> Cache -> Either (Bool, Text) (Collect, Stream d) find_generator_cache Type typ CacheKey key Range range ScoreDamage score (ControlDamage Ranges ScoreTime control) (Cache Map CacheKey Cached cache) = do Cached cached <- forall err a. err -> Maybe a -> Either err a justErr (Bool False, Text "not in cache") forall a b. (a -> b) -> a -> b $ forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup CacheKey key Map CacheKey Cached cache -- Look for block damage before looking for Invalid, because if there is -- block damage I inflict control damage too. This is because block damage -- means things like a block title change, or skeleton change, and those -- can invalidate all blocks called from this one. let stack :: [Frame] stack = Stack -> [Frame] Stack.innermost (CacheKey -> Stack Derive.key_stack CacheKey key) case Type typ of Block BlockId _block_id -> case forall (t :: * -> *) (m :: * -> *) a. (Foldable t, MonadPlus m) => t (m a) -> m a msum (forall a b. (a -> b) -> [a] -> [b] map Frame -> Maybe BlockId Stack.block_of [Frame] stack) of Just BlockId this_block | BlockId this_block forall a. Ord a => a -> Set a -> Bool `Set.member` ScoreDamage -> Set BlockId sdamage_blocks ScoreDamage score -> forall a b. a -> Either a b Left (Bool True, Text "direct block damage") | BlockId this_block forall a. Ord a => a -> Set a -> Bool `Set.member` ScoreDamage -> Set BlockId sdamage_track_blocks ScoreDamage score -> forall a b. a -> Either a b Left (Bool False, Text "track block damage") Maybe BlockId _ -> forall (m :: * -> *) a. Monad m => a -> m a return () Track TrackId _track_id Set TrackId children | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any (forall a. Ord a => a -> Set a -> Bool `Set.member` Set TrackId children) (forall k a. Map k a -> [k] Map.keys (ScoreDamage -> Map TrackId (Ranges ScoreTime) sdamage_tracks ScoreDamage score)) -> forall a b. a -> Either a b Left (Bool False, Text "track damage") | Bool otherwise -> forall (m :: * -> *) a. Monad m => a -> m a return () Derive.CallType Collect collect Stream d stream <- case Cached cached of Cached Invalid -> forall a b. a -> Either a b Left (Bool False, Text "cache invalidated by score damage") Cached CacheEntry entry -> forall err a. err -> Maybe a -> Either err a justErr (Bool False, Text "cache has wrong type") forall a b. (a -> b) -> a -> b $ forall d. Cacheable d => CacheEntry -> Maybe (CallType d) from_cache_entry CacheEntry entry let Derive.BlockDeps Set BlockId block_deps = Collect -> BlockDeps Derive.collect_block_deps Collect collect let damaged_blocks :: Set BlockId damaged_blocks = forall a. Ord a => Set a -> Set a -> Set a Set.union (ScoreDamage -> Set BlockId sdamage_track_blocks ScoreDamage score) (ScoreDamage -> Set BlockId sdamage_blocks ScoreDamage score) forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (forall a. Set a -> Bool Set.null (forall a. Ord a => Set a -> Set a -> Set a Set.intersection Set BlockId damaged_blocks Set BlockId block_deps)) forall a b. (a -> b) -> a -> b $ forall a b. a -> Either a b Left (Bool False, Text "sub-block damage") -- Negative duration indicates an arrival note. The block deriver then -- takes the controls from the bottom of event (which is the start), -- see "Derive.Call.Block". let overlapping :: Ranges ScoreTime -> Ranges ScoreTime -> Bool overlapping = if Range -> Bool _negative Range range then forall n. Ord n => Ranges n -> Ranges n -> Bool Ranges.overlapping_closed else forall n. Ord n => Ranges n -> Ranges n -> Bool Ranges.overlapping forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Ranges ScoreTime -> Ranges ScoreTime -> Bool overlapping Ranges ScoreTime control (forall n. n -> n -> Ranges n Ranges.range (Range -> ScoreTime _start Range range) (Range -> ScoreTime _end Range range))) forall a b. (a -> b) -> a -> b $ forall a b. a -> Either a b Left (Bool True, Text "control damage") forall (m :: * -> *) a. Monad m => a -> m a return (Collect collect, Stream d stream) -- | Make a single cache entry. This will go into 'Derive.collect_cache' -- and be merged in with the rest. make_cache :: Cacheable d => Derive.CacheKey -> Derive.Collect -> Stream.Stream d -> Cache make_cache :: forall d. Cacheable d => CacheKey -> Collect -> Stream d -> Cache make_cache CacheKey key Collect collect Stream d stream = Map CacheKey Cached -> Cache Cache forall a b. (a -> b) -> a -> b $ forall k a. k -> a -> Map k a Map.singleton CacheKey key (CacheEntry -> Cached Cached CacheEntry entry) where stripped :: Collect stripped = Collect collect { collect_cache :: Cache Derive.collect_cache = forall a. Monoid a => a mempty -- integration shouldn't happen if the cache is reused, since that -- means nothing changed. So this reduces unnecessary reintegration. , collect_integrated :: [Integrated] Derive.collect_integrated = [] -- Use Map.map instead of fmap, since fmap is lazy. , collect_track_dynamic :: TrackDynamic Derive.collect_track_dynamic = forall a b k. (a -> b) -> Map k a -> Map k b Map.map Dynamic -> Dynamic Derive.strip_dynamic (Collect -> TrackDynamic Derive.collect_track_dynamic Collect collect) , collect_track_dynamic_inverted :: TrackDynamic Derive.collect_track_dynamic_inverted = forall a b k. (a -> b) -> Map k a -> Map k b Map.map Dynamic -> Dynamic Derive.strip_dynamic (Collect -> TrackDynamic Derive.collect_track_dynamic_inverted Collect collect) } entry :: CacheEntry entry = forall d. Cacheable d => CallType d -> CacheEntry to_cache_entry forall a b. (a -> b) -> a -> b $ forall d. Collect -> Stream d -> CallType d Derive.CallType Collect stripped forall a b. (a -> b) -> a -> b $ forall a. [LEvent a] -> Stream a Stream.from_sorted_list forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {d}. LEvent d -> Bool cache_log) forall a b. (a -> b) -> a -> b $ forall a. Stream a -> [LEvent a] Stream.to_list Stream d stream -- I do want a cached chunk to retain its log msgs, since those include -- errors deriving. However, it's confusing if it also includes cache -- msgs because then it looks like it wasn't cached after all. -- It's unfortunate that I have to copy the chunk, but it's either this -- or a more complicated filtering scheme later on, which is bound to -- be just a filter too. At least this way it only happens once. cache_log :: LEvent d -> Bool cache_log = forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a LEvent.either (forall a b. a -> b -> a const Bool False) Msg -> Bool is_cache_log -- * logs is_cache_log :: Log.Msg -> Bool is_cache_log :: Msg -> Bool is_cache_log Msg msg = forall a. Maybe a -> Bool Maybe.isJust (Msg -> Maybe Int cache_hit_events Msg msg) Bool -> Bool -> Bool || forall a. Maybe a -> Bool Maybe.isJust (Msg -> Maybe Text cache_miss_reason Msg msg) cache_hit :: Text cache_hit :: Text cache_hit = Text "cache-hit" cache_hit_msg :: Stream.Stream a -> Log.Msg cache_hit_msg :: forall a. Stream a -> Msg cache_hit_msg Stream a cached = Text -> Int -> Msg -> Msg Log.with_int Text cache_hit Int events forall a b. (a -> b) -> a -> b $ Stack => Priority -> Maybe Stack -> Text -> Msg Log.msg Priority Log.Debug forall a. Maybe a Nothing forall a b. (a -> b) -> a -> b $ Text "using cache, " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Int events forall a. Semigroup a => a -> a -> a <> Text " events, " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Integer logs forall a. Semigroup a => a -> a -> a <> Text " logs" where (Int events, Integer logs) = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' forall {a} {b} {a}. (Num a, Num b) => (a, b) -> LEvent a -> (a, b) count (Int 0, Integer 0) (forall a. Stream a -> [LEvent a] Stream.to_list Stream a cached) count :: (a, b) -> LEvent a -> (a, b) count (!a es, !b ms) LEvent a e = if forall {d}. LEvent d -> Bool LEvent.is_event LEvent a e then (a esforall a. Num a => a -> a -> a +a 1, b ms) else (a es, b msforall a. Num a => a -> a -> a +b 1) -- | Get the number of cached events from a 'cache_hit_msg'. cache_hit_events :: Log.Msg -> Maybe Int cache_hit_events :: Msg -> Maybe Int cache_hit_events = Text -> Msg -> Maybe Int Log.lookup_int Text cache_hit cache_miss :: Text cache_miss :: Text cache_miss = Text "cache-miss" cache_miss_msg :: Text -> Log.Msg cache_miss_msg :: Text -> Msg cache_miss_msg Text reason = Text -> Text -> Msg -> Msg Log.with_text Text cache_miss Text reason forall a b. (a -> b) -> a -> b $ Stack => Priority -> Maybe Stack -> Text -> Msg Log.msg Priority Log.Debug forall a. Maybe a Nothing forall a b. (a -> b) -> a -> b $ Text "rederived generator because of " forall a. Semigroup a => a -> a -> a <> Text reason -- | Get the reason from a 'cache_miss_msg'. cache_miss_reason :: Log.Msg -> Maybe Text cache_miss_reason :: Msg -> Maybe Text cache_miss_reason = Text -> Msg -> Maybe Text Log.lookup_text Text cache_miss -- * debugging -- | Format the cache in a hopefully readable way. pretty_cache :: Derive.Cache -> Text pretty_cache :: Cache -> Text pretty_cache (Derive.Cache Map CacheKey Cached cache) = [Text] -> Text Text.unlines forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ Stack -> Text Stack.pretty_ui_ Stack stack forall a. Semigroup a => a -> a -> a <> Text ": " forall a. a -> [a] -> [a] : forall a b. (a -> b) -> [a] -> [b] map (Text " "<>) (Cached -> [Text] fmt Cached cached) forall a. [a] -> [a] -> [a] ++ [Text ""] | (Derive.CacheKey Stack stack, Cached cached) <- forall k a. Map k a -> [(k, a)] Map.toList Map CacheKey Cached cache ] where fmt :: Cached -> [Text] fmt Cached Derive.Invalid = [Text "Invalid"] fmt (Derive.Cached CacheEntry cached) = case CacheEntry cached of Derive.CachedEvents (Derive.CallType Collect _ Stream Event a) -> Stream Event -> [Text] Stream.short_events Stream Event a Derive.CachedControl (Derive.CallType Collect _ Stream Control a) -> [forall a. Pretty a => a -> Text pretty Stream Control a] Derive.CachedPitch (Derive.CallType Collect _ Stream PSignal a) -> [forall a. Pretty a => a -> Text pretty Stream PSignal a] -- * get_control_damage {- | ScoreDamage on the current track is converted into ControlDamage, and expanded to the neighbor events. This is because control calls emit samples between their previous or next events. Then this is merged with any ControlDamage inherited from callers. If a block call is touched by control damage, the the control damage expands to cover the entire block. Previously, this inherited damage would also be expanded to its neighbor events, under the rationale that controls can modify other controls. While this is true, it causes an annoying situation where a control track with a single call under (say) a tempo track will cause any edits to the tempo track to invalidate the entire score. This happens a lot in practice, and I've forgotten about this wrinkle a number of times The downside, of course, is that control damage will not cause a control call that lies before its previous event to rederive, even if it should have. I'll have to see how annoying this is in practice. -} get_control_damage :: BlockId -> TrackId -> (ScoreTime, ScoreTime) -- ^ track_range must be passed explicitly -- because the event may have been sliced and shifted, but ControlDamage -- should be relative to the start of the track at ScoreTime 0. -> Derive.Deriver ControlDamage get_control_damage :: BlockId -> TrackId -> (ScoreTime, ScoreTime) -> Deriver ControlDamage get_control_damage BlockId block_id TrackId track_id (ScoreTime, ScoreTime) track_range = do State st <- forall st err. Deriver st err st Derive.get let control :: ControlDamage control = Dynamic -> ControlDamage Derive.state_control_damage (State -> Dynamic Derive.state_dynamic State st) score :: ScoreDamage score = Constant -> ScoreDamage Derive.state_score_damage (State -> Constant Derive.state_constant State st) (ControlDamage control<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> TrackId -> (ScoreTime, ScoreTime) -> ControlDamage -> Deriver ControlDamage extend_damage TrackId track_id (ScoreTime, ScoreTime) track_range (BlockId -> TrackId -> ScoreDamage -> ControlDamage score_to_control BlockId block_id TrackId track_id ScoreDamage score) {- | Since the warp is the integral of the tempo track, damage on the tempo track will affect all events after it. Actually, the damage extends from the previous event to the end of the track, since interpolating calls extend from the previous event. It would be simpler to have any edit invalidate the whole track, but it seems like editing a score at the end is a common case, and it would be a shame to rederive the entire score on each edit when only the very end has changed. -} get_tempo_damage :: BlockId -> TrackId -> TrackTime -> Events.Events -> Derive.Deriver ControlDamage get_tempo_damage :: BlockId -> TrackId -> ScoreTime -> Events -> Deriver ControlDamage get_tempo_damage BlockId block_id TrackId track_id ScoreTime track_end Events events = do State st <- forall st err. Deriver st err st Derive.get let control :: ControlDamage control = Dynamic -> ControlDamage Derive.state_control_damage (State -> Dynamic Derive.state_dynamic State st) score :: ScoreDamage score = Constant -> ScoreDamage Derive.state_score_damage (State -> Constant Derive.state_constant State st) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ ControlDamage -> ControlDamage extend forall a b. (a -> b) -> a -> b $ ControlDamage control forall a. Semigroup a => a -> a -> a <> BlockId -> TrackId -> ScoreDamage -> ControlDamage score_to_control BlockId block_id TrackId track_id ScoreDamage score where extend :: ControlDamage -> ControlDamage extend (Derive.ControlDamage Ranges ScoreTime ranges) = Ranges ScoreTime -> ControlDamage Derive.ControlDamage forall a b. (a -> b) -> a -> b $ case forall n. Ranges n -> Maybe [(n, n)] Ranges.extract Ranges ScoreTime ranges of Maybe [(ScoreTime, ScoreTime)] Nothing -> forall n. Ranges n Ranges.everything Just [] -> forall n. Ranges n Ranges.nothing Just ((ScoreTime s, ScoreTime _) : [(ScoreTime, ScoreTime)] _) -> case ScoreTime -> Events -> ([Event], [Event]) Events.split_lists ScoreTime s Events events of (Event prev : [Event] _, [Event] _) -> forall n. n -> n -> Ranges n Ranges.range (Event -> ScoreTime Event.start Event prev) ScoreTime track_end ([], [Event] _) -> forall n. n -> n -> Ranges n Ranges.range ScoreTime s ScoreTime track_end -- | Convert score damage directly to ControlDamage on a given track. score_to_control :: BlockId -> TrackId -> ScoreDamage -> ControlDamage score_to_control :: BlockId -> TrackId -> ScoreDamage -> ControlDamage score_to_control BlockId block_id TrackId track_id ScoreDamage score = Ranges ScoreTime -> ControlDamage ControlDamage forall a b. (a -> b) -> a -> b $ (if BlockId block_id forall a. Ord a => a -> Set a -> Bool `Set.member` ScoreDamage -> Set BlockId Derive.sdamage_blocks ScoreDamage score then forall n. Ranges n Ranges.everything else forall n. Ranges n Ranges.nothing) forall a. Semigroup a => a -> a -> a <> forall k a. Ord k => a -> k -> Map k a -> a Map.findWithDefault forall n. Ranges n Ranges.nothing TrackId track_id (ScoreDamage -> Map TrackId (Ranges ScoreTime) Derive.sdamage_tracks ScoreDamage score) -- | Extend the given ControlDamage as described in 'get_control_damage'. -- Somewhat tricky because I also want to clip the damage to the track range, -- if any. This is so a sliced control track below an unsliced one won't -- bother figuring out damage outside its range. extend_damage :: TrackId -> (ScoreTime, ScoreTime) -> ControlDamage -> Derive.Deriver ControlDamage extend_damage :: TrackId -> (ScoreTime, ScoreTime) -> ControlDamage -> Deriver ControlDamage extend_damage TrackId track_id (ScoreTime, ScoreTime) track_range (ControlDamage Ranges ScoreTime damage) | Ranges ScoreTime damage forall a. Eq a => a -> a -> Bool == forall a. Monoid a => a mempty = forall (m :: * -> *) a. Monad m => a -> m a return forall a. Monoid a => a mempty | Bool otherwise = do Events events <- Track -> Events Track.track_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> TrackId -> Deriver Track Derive.get_track TrackId track_id forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Ranges ScoreTime -> ControlDamage ControlDamage forall a b. (a -> b) -> a -> b $ Events -> Ranges ScoreTime extend Events events where extend :: Events -> Ranges ScoreTime extend Events events | Events -> Bool Events.null Events events = Ranges ScoreTime damage | Bool otherwise = forall n. Ord n => Ranges n -> Ranges n -> Ranges n Ranges.intersection (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry forall n. n -> n -> Ranges n Ranges.range (ScoreTime, ScoreTime) track_range) forall a b. (a -> b) -> a -> b $ ScoreTime -> Events -> Ranges ScoreTime -> Ranges ScoreTime _extend_control_damage (forall a b. (a, b) -> b snd (ScoreTime, ScoreTime) track_range) Events events Ranges ScoreTime damage _extend_control_damage :: ScoreTime -> Events.Events -> Ranges.Ranges ScoreTime -> Ranges.Ranges ScoreTime _extend_control_damage :: ScoreTime -> Events -> Ranges ScoreTime -> Ranges ScoreTime _extend_control_damage ScoreTime track_end Events events = forall b a. Ord b => ((a, a) -> (b, b)) -> Ranges a -> Ranges b Ranges.pair_map (Events -> (ScoreTime, ScoreTime) -> (ScoreTime, ScoreTime) extend1 Events events) where extend1 :: Events -> (ScoreTime, ScoreTime) -> (ScoreTime, ScoreTime) extend1 Events events (ScoreTime s, ScoreTime e) = (ScoreTime -> Events -> ScoreTime event_at_before ScoreTime s Events events, ScoreTime -> Events -> ScoreTime event_after ScoreTime e Events events) event_at_before :: ScoreTime -> Events -> ScoreTime event_at_before ScoreTime p Events events = case ScoreTime -> Events -> ([Event], [Event]) Events.split_lists ScoreTime p Events events of ([Event] _, Event at : [Event] _) | ScoreTime p forall a. Eq a => a -> a -> Bool == Event -> ScoreTime Event.start Event at -> ScoreTime p (Event prev : [Event] _, [Event] _) -> Event -> ScoreTime Event.start Event prev ([Event], [Event]) _ -> ScoreTime p event_after :: ScoreTime -> Events -> ScoreTime event_after ScoreTime p Events events = forall b a. b -> (a -> b) -> Maybe a -> b maybe ScoreTime track_end Event -> ScoreTime Event.start forall a b. (a -> b) -> a -> b $ forall a. [a] -> Maybe a Lists.head (ScoreTime -> Events -> [Event] Events.after ScoreTime p Events events)