-- 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.Log as Log
import qualified Util.Ranges as Ranges
import qualified Util.Seq as Seq

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 qualified Derive.Args as Args
import qualified Derive.Derive as Derive
import Derive.Derive (Cache(..), Cached(..), ScoreDamage(..), ControlDamage(..))
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 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) = CallType Event -> Maybe (CallType Event)
forall a. a -> Maybe a
Just CallType Event
ctype
    from_cache_entry CacheEntry
_ = Maybe (CallType Event)
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) = CallType Control -> Maybe (CallType Control)
forall a. a -> Maybe a
Just CallType Control
ctype
    from_cache_entry CacheEntry
_ = Maybe (CallType Control)
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) = CallType PSignal -> Maybe (CallType PSignal)
forall a. a -> Maybe a
Just CallType PSignal
ctype
    from_cache_entry CacheEntry
_ = Maybe (CallType PSignal)
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
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
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
(Int -> Type -> ShowS)
-> (Type -> String) -> ([Type] -> ShowS) -> Show Type
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 = Type -> Range -> NoteDeriver -> NoteDeriver
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 = (ScoreTime, ScoreTime) -> ScoreTime
forall a b. (a, b) -> a
fst ((ScoreTime, ScoreTime) -> ScoreTime)
-> (ScoreTime, ScoreTime) -> ScoreTime
forall a b. (a -> b) -> a -> b
$ PassedArgs d -> (ScoreTime, ScoreTime)
forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_on_track PassedArgs d
args
        , _end :: ScoreTime
_end = (ScoreTime, ScoreTime) -> ScoreTime
forall a b. (a, b) -> b
snd ((ScoreTime, ScoreTime) -> ScoreTime)
-> (ScoreTime, ScoreTime) -> ScoreTime
forall a b. (a -> b) -> a -> b
$ PassedArgs d -> (ScoreTime, ScoreTime)
forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_on_track PassedArgs d
args
        , _negative :: Bool
_negative = Event -> Bool
Event.is_negative (PassedArgs d -> Event
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
(Int -> Range -> ShowS)
-> (Range -> String) -> ([Range] -> ShowS) -> Show Range
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 -> Type -> Range -> Deriver (Stream d) -> Deriver (Stream d)
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 Sliced -> Sliced -> Bool
forall a. Eq a => a -> a -> Bool
== Sliced
TrackTree.NotSliced =
        Track -> Maybe TrackId
TrackTree.track_id Track
track
    | Bool
otherwise = Maybe TrackId
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 <- Deriver State Error State
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 (Either (Bool, Text) (Collect, Stream d) -> Deriver (Stream d))
-> Either (Bool, Text) (Collect, Stream d) -> Deriver (Stream d)
forall a b. (a -> b) -> a -> b
$ Type
-> CacheKey
-> Range
-> ScoreDamage
-> ControlDamage
-> Cache
-> Either (Bool, Text) (Collect, Stream d)
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
        Msg -> Deriver State Error ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write (Msg -> Deriver State Error ()) -> Msg -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Stream d -> Msg
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 (Collect -> Deriver State Error ())
-> Collect -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$
            Collect
forall a. Monoid a => a
mempty { collect_cache_stats :: CacheStats
Derive.collect_cache_stats = CacheStats
stats } Collect -> Collect -> Collect
forall a. Semigroup a => a -> a -> a
<> Collect
collect
        Stream d -> Deriver (Stream d)
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) <- Bool
-> Deriver (Stream d) -> Deriver State Error (Stream d, Collect)
forall {a}. Bool -> Deriver a -> Deriver State Error (a, Collect)
with_collect Bool
inflict_control_damage Deriver (Stream d)
call
        Msg -> Deriver State Error ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write (Msg -> Deriver State Error ()) -> Msg -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Text -> Msg
cache_miss_msg Text
reason
        Collect -> Deriver State Error ()
Internal.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_cache :: Cache
Derive.collect_cache =
                CacheKey -> Collect -> Stream d -> Cache
forall d. Cacheable d => CacheKey -> Collect -> Stream d -> Cache
make_cache (Stack -> CacheKey
Derive.CacheKey Stack
stack) Collect
collect Stream d
result
            }
        Stream d -> Deriver (Stream d)
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) <- Bool -> Deriver a -> Deriver State Error (a, 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
        (a, Collect) -> Deriver State Error (a, 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 <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    RealTime
end <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
    CacheStats -> Deriver CacheStats
forall (m :: * -> *) a. Monad m => a -> m a
return (CacheStats -> Deriver CacheStats)
-> CacheStats -> Deriver CacheStats
forall a b. (a -> b) -> a -> b
$ CacheStats
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 -> BlockId -> Either BlockId TrackId
forall a b. a -> Either a b
Left BlockId
block_id
        Track TrackId
track_id Set TrackId
_ -> TrackId -> Either BlockId 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 <- Deriver State Error State
forall st err. Deriver st err st
Derive.get
    (State -> State) -> Deriver State Error ()
forall st err. (st -> st) -> Deriver st err ()
Derive.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
Derive.state_collect = 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 Ranges ScoreTime
forall n. Ranges n
Ranges.everything
                }
            else State -> Dynamic
Derive.state_dynamic State
st
        }
    a
result <- Deriver a
deriver
    Collect
collect <- (State -> Collect) -> Deriver State Error Collect
forall st a err. (st -> a) -> Deriver st err a
Derive.gets State -> Collect
Derive.state_collect
    State -> Deriver State Error ()
forall st err. st -> Deriver st err ()
Derive.put State
old
    (a, Collect) -> Deriver (a, Collect)
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 <- (Bool, Text) -> Maybe Cached -> Either (Bool, Text) Cached
forall err a. err -> Maybe a -> Either err a
justErr (Bool
False, Text
"not in cache") (Maybe Cached -> Either (Bool, Text) Cached)
-> Maybe Cached -> Either (Bool, Text) Cached
forall a b. (a -> b) -> a -> b
$ CacheKey -> Map CacheKey Cached -> Maybe Cached
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 [Maybe BlockId] -> Maybe BlockId
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((Frame -> Maybe BlockId) -> [Frame] -> [Maybe BlockId]
forall a b. (a -> b) -> [a] -> [b]
map Frame -> Maybe BlockId
Stack.block_of [Frame]
stack) of
            Just BlockId
this_block
                | BlockId
this_block BlockId -> Set BlockId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ScoreDamage -> Set BlockId
sdamage_blocks ScoreDamage
score ->
                    (Bool, Text) -> Either (Bool, Text) ()
forall a b. a -> Either a b
Left (Bool
True, Text
"direct block damage")
                | BlockId
this_block BlockId -> Set BlockId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ScoreDamage -> Set BlockId
sdamage_track_blocks ScoreDamage
score ->
                    (Bool, Text) -> Either (Bool, Text) ()
forall a b. a -> Either a b
Left (Bool
False, Text
"track block damage")
            Maybe BlockId
_ -> () -> Either (Bool, Text) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Track TrackId
_track_id Set TrackId
children
            | (TrackId -> Bool) -> [TrackId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TrackId -> Set TrackId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
children) (Map TrackId (Ranges ScoreTime) -> [TrackId]
forall k a. Map k a -> [k]
Map.keys (ScoreDamage -> Map TrackId (Ranges ScoreTime)
sdamage_tracks ScoreDamage
score)) ->
                (Bool, Text) -> Either (Bool, Text) ()
forall a b. a -> Either a b
Left (Bool
False, Text
"track damage")
            | Bool
otherwise -> () -> Either (Bool, Text) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Derive.CallType Collect
collect Stream d
stream <- case Cached
cached of
        Cached
Invalid -> (Bool, Text) -> Either (Bool, Text) (CallType d)
forall a b. a -> Either a b
Left (Bool
False, Text
"cache invalidated by score damage")
        Cached CacheEntry
entry -> (Bool, Text)
-> Maybe (CallType d) -> Either (Bool, Text) (CallType d)
forall err a. err -> Maybe a -> Either err a
justErr (Bool
False, Text
"cache has wrong type") (Maybe (CallType d) -> Either (Bool, Text) (CallType d))
-> Maybe (CallType d) -> Either (Bool, Text) (CallType d)
forall a b. (a -> b) -> a -> b
$
            CacheEntry -> Maybe (CallType d)
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 = Set BlockId -> Set BlockId -> Set BlockId
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)
    Bool -> Either (Bool, Text) () -> Either (Bool, Text) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set BlockId -> Bool
forall a. Set a -> Bool
Set.null (Set BlockId -> Set BlockId -> Set BlockId
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set BlockId
damaged_blocks Set BlockId
block_deps)) (Either (Bool, Text) () -> Either (Bool, Text) ())
-> Either (Bool, Text) () -> Either (Bool, Text) ()
forall a b. (a -> b) -> a -> b
$
        (Bool, Text) -> Either (Bool, Text) ()
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 Ranges ScoreTime -> Ranges ScoreTime -> Bool
forall n. Ord n => Ranges n -> Ranges n -> Bool
Ranges.overlapping_closed
            else Ranges ScoreTime -> Ranges ScoreTime -> Bool
forall n. Ord n => Ranges n -> Ranges n -> Bool
Ranges.overlapping
    Bool -> Either (Bool, Text) () -> Either (Bool, Text) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ranges ScoreTime -> Ranges ScoreTime -> Bool
overlapping Ranges ScoreTime
control (ScoreTime -> ScoreTime -> Ranges ScoreTime
forall n. n -> n -> Ranges n
Ranges.range (Range -> ScoreTime
_start Range
range) (Range -> ScoreTime
_end Range
range))) (Either (Bool, Text) () -> Either (Bool, Text) ())
-> Either (Bool, Text) () -> Either (Bool, Text) ()
forall a b. (a -> b) -> a -> b
$
        (Bool, Text) -> Either (Bool, Text) ()
forall a b. a -> Either a b
Left (Bool
True, Text
"control damage")
    (Collect, Stream d) -> Either (Bool, Text) (Collect, Stream d)
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 (Map CacheKey Cached -> Cache) -> Map CacheKey Cached -> Cache
forall a b. (a -> b) -> a -> b
$ CacheKey -> Cached -> Map CacheKey Cached
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 = 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 =
            (Dynamic -> Dynamic) -> TrackDynamic -> TrackDynamic
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 =
            (Dynamic -> Dynamic) -> TrackDynamic -> TrackDynamic
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 = CallType d -> CacheEntry
forall d. Cacheable d => CallType d -> CacheEntry
to_cache_entry (CallType d -> CacheEntry) -> CallType d -> CacheEntry
forall a b. (a -> b) -> a -> b
$ Collect -> Stream d -> CallType d
forall d. Collect -> Stream d -> CallType d
Derive.CallType Collect
stripped (Stream d -> CallType d) -> Stream d -> CallType d
forall a b. (a -> b) -> a -> b
$
        [LEvent d] -> Stream d
forall a. [LEvent a] -> Stream a
Stream.from_sorted_list ([LEvent d] -> Stream d) -> [LEvent d] -> Stream d
forall a b. (a -> b) -> a -> b
$ (LEvent d -> Bool) -> [LEvent d] -> [LEvent d]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LEvent d -> Bool) -> LEvent d -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEvent d -> Bool
forall {d}. LEvent d -> Bool
cache_log) ([LEvent d] -> [LEvent d]) -> [LEvent d] -> [LEvent d]
forall a b. (a -> b) -> a -> b
$
        Stream d -> [LEvent d]
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 = (d -> Bool) -> (Msg -> Bool) -> LEvent d -> Bool
forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a
LEvent.either (Bool -> d -> Bool
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 =
    Maybe Int -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Msg -> Maybe Int
cache_hit_events Msg
msg) Bool -> Bool -> Bool
|| Maybe Text -> 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 (Msg -> Msg) -> Msg -> Msg
forall a b. (a -> b) -> a -> b
$ Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Debug Maybe Stack
forall a. Maybe a
Nothing (Text -> Msg) -> Text -> Msg
forall a b. (a -> b) -> a -> b
$
        Text
"using cache, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
events Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" events, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Show a => a -> Text
showt Integer
logs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" logs"
    where
    (Int
events, Integer
logs) = ((Int, Integer) -> LEvent a -> (Int, Integer))
-> (Int, Integer) -> [LEvent a] -> (Int, Integer)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Integer) -> LEvent a -> (Int, Integer)
forall {a} {b} {a}. (Num a, Num b) => (a, b) -> LEvent a -> (a, b)
count (Int
0, Integer
0) (Stream a -> [LEvent a]
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 LEvent a -> Bool
forall {d}. LEvent d -> Bool
LEvent.is_event LEvent a
e then (a
esa -> a -> a
forall a. Num a => a -> a -> a
+a
1, b
ms) else (a
es, b
msb -> b -> b
forall 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 (Msg -> Msg) -> Msg -> Msg
forall a b. (a -> b) -> a -> b
$
    Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Debug Maybe Stack
forall a. Maybe a
Nothing (Text -> Msg) -> Text -> Msg
forall a b. (a -> b) -> a -> b
$ Text
"rederived generator because of " Text -> Text -> Text
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 ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Stack -> Text
Stack.pretty_ui_ Stack
stack Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"    "<>) (Cached -> [Text]
fmt Cached
cached) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
""]
    | (Derive.CacheKey Stack
stack, Cached
cached) <- Map CacheKey Cached -> [(CacheKey, 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) -> [Stream Control -> Text
forall a. Pretty a => a -> Text
pretty Stream Control
a]
        Derive.CachedPitch (Derive.CallType Collect
_ Stream PSignal
a) -> [Stream PSignal -> Text
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 <- Deriver State Error State
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<>) (ControlDamage -> ControlDamage)
-> Deriver ControlDamage -> Deriver ControlDamage
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 <- Deriver State Error State
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 -> Deriver ControlDamage
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlDamage -> Deriver ControlDamage)
-> ControlDamage -> Deriver ControlDamage
forall a b. (a -> b) -> a -> b
$ ControlDamage -> ControlDamage
extend (ControlDamage -> ControlDamage) -> ControlDamage -> ControlDamage
forall a b. (a -> b) -> a -> b
$ ControlDamage
control ControlDamage -> ControlDamage -> ControlDamage
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 (Ranges ScoreTime -> ControlDamage)
-> Ranges ScoreTime -> ControlDamage
forall a b. (a -> b) -> a -> b
$
        case Ranges ScoreTime -> Maybe [(ScoreTime, ScoreTime)]
forall n. Ranges n -> Maybe [(n, n)]
Ranges.extract Ranges ScoreTime
ranges of
            Maybe [(ScoreTime, ScoreTime)]
Nothing -> Ranges ScoreTime
forall n. Ranges n
Ranges.everything
            Just [] -> Ranges ScoreTime
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]
_) ->
                    ScoreTime -> ScoreTime -> Ranges ScoreTime
forall n. n -> n -> Ranges n
Ranges.range (Event -> ScoreTime
Event.start Event
prev) ScoreTime
track_end
                ([], [Event]
_) -> ScoreTime -> ScoreTime -> Ranges ScoreTime
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 (Ranges ScoreTime -> ControlDamage)
-> Ranges ScoreTime -> ControlDamage
forall a b. (a -> b) -> a -> b
$
    (if BlockId
block_id BlockId -> Set BlockId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ScoreDamage -> Set BlockId
Derive.sdamage_blocks ScoreDamage
score
        then Ranges ScoreTime
forall n. Ranges n
Ranges.everything else Ranges ScoreTime
forall n. Ranges n
Ranges.nothing)
    Ranges ScoreTime -> Ranges ScoreTime -> Ranges ScoreTime
forall a. Semigroup a => a -> a -> a
<> Ranges ScoreTime
-> TrackId -> Map TrackId (Ranges ScoreTime) -> Ranges ScoreTime
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Ranges ScoreTime
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 Ranges ScoreTime -> Ranges ScoreTime -> Bool
forall a. Eq a => a -> a -> Bool
== Ranges ScoreTime
forall a. Monoid a => a
mempty = ControlDamage -> Deriver ControlDamage
forall (m :: * -> *) a. Monad m => a -> m a
return ControlDamage
forall a. Monoid a => a
mempty
    | Bool
otherwise = do
        Events
events <- Track -> Events
Track.track_events (Track -> Events)
-> Deriver State Error Track -> Deriver State Error Events
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackId -> Deriver State Error Track
Derive.get_track TrackId
track_id
        ControlDamage -> Deriver ControlDamage
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlDamage -> Deriver ControlDamage)
-> ControlDamage -> Deriver ControlDamage
forall a b. (a -> b) -> a -> b
$ Ranges ScoreTime -> ControlDamage
ControlDamage (Ranges ScoreTime -> ControlDamage)
-> Ranges ScoreTime -> 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 = Ranges ScoreTime -> Ranges ScoreTime -> Ranges ScoreTime
forall n. Ord n => Ranges n -> Ranges n -> Ranges n
Ranges.intersection ((ScoreTime -> ScoreTime -> Ranges ScoreTime)
-> (ScoreTime, ScoreTime) -> Ranges ScoreTime
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ScoreTime -> ScoreTime -> Ranges ScoreTime
forall n. n -> n -> Ranges n
Ranges.range (ScoreTime, ScoreTime)
track_range) (Ranges ScoreTime -> Ranges ScoreTime)
-> Ranges ScoreTime -> Ranges ScoreTime
forall a b. (a -> b) -> a -> b
$
            ScoreTime -> Events -> Ranges ScoreTime -> Ranges ScoreTime
_extend_control_damage ((ScoreTime, ScoreTime) -> ScoreTime
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 = ((ScoreTime, ScoreTime) -> (ScoreTime, ScoreTime))
-> Ranges ScoreTime -> Ranges ScoreTime
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 ScoreTime -> ScoreTime -> Bool
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 = ScoreTime -> (Event -> ScoreTime) -> Maybe Event -> ScoreTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScoreTime
track_end Event -> ScoreTime
Event.start (Maybe Event -> ScoreTime) -> Maybe Event -> ScoreTime
forall a b. (a -> b) -> a -> b
$
        [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head (ScoreTime -> Events -> [Event]
Events.after ScoreTime
p Events
events)