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