-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{- | This module is sister to "Derive.Deriver.Lib", except that it contains
    functions which are normally only used by the built-in track derivation
    scheme, and are not used when writing most normal calls.
-}
module Derive.Deriver.Internal where
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

import qualified Util.CallStack as CallStack
import qualified Util.Log as Log
import qualified Util.Seed as Seed

import qualified Derive.DeriveT as DeriveT
import qualified Derive.EnvKey as EnvKey
import qualified Derive.PSignal as PSignal
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack
import qualified Derive.TrackWarp as TrackWarp
import qualified Derive.Warp as Warp

import qualified Ui.Block as Block
import qualified Ui.Ruler as Ruler
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Derive.Deriver.Monad
import           Global
import           Types


-- * generic state access

get_dynamic :: (Dynamic -> a) -> Deriver a
get_dynamic :: forall a. (Dynamic -> a) -> Deriver a
get_dynamic Dynamic -> a
f = (State -> a) -> Deriver State Error a
forall st a err. (st -> a) -> Deriver st err a
gets (Dynamic -> a
f (Dynamic -> a) -> (State -> Dynamic) -> State -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
state_dynamic)

get_constant :: (Constant -> a) -> Deriver a
get_constant :: forall a. (Constant -> a) -> Deriver a
get_constant Constant -> a
f = (State -> a) -> Deriver State Error a
forall st a err. (st -> a) -> Deriver st err a
gets (Constant -> a
f (Constant -> a) -> (State -> Constant) -> State -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant)

-- | This is a little different from Reader.local because only a portion of
-- the state is used Reader-style.
--
-- Note that this doesn't restore the state on an exception.  I think this
-- is ok because exceptions are always \"caught\" at the event evaluation
-- level since it runs each one separately.  Since the state dynamic state
-- (i.e. except Collect) from the sub derivation is discarded, whatever state
-- it's in after the exception shouldn't matter.
local :: (Dynamic -> Dynamic) -> Deriver a -> Deriver a
local :: forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
local Dynamic -> Dynamic
modify_dynamic = (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
localm (Dynamic -> Deriver Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic -> Deriver Dynamic)
-> (Dynamic -> Dynamic) -> Dynamic -> Deriver Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Dynamic
modify_dynamic)

localm :: (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
localm :: forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
localm Dynamic -> Deriver Dynamic
modify_dynamic Deriver a
deriver = do
    State
st <- Deriver State Error State
forall st err. Deriver st err st
get
    Dynamic
new <- Dynamic -> Deriver Dynamic
modify_dynamic (State -> Dynamic
state_dynamic State
st)
    State -> Deriver State Error ()
forall st err. st -> Deriver st err ()
put (State -> Deriver State Error ())
-> State -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ State
st { state_dynamic :: Dynamic
state_dynamic = Dynamic
new }
    a
result <- Deriver a
deriver
    (State -> State) -> Deriver State Error ()
forall st err. (st -> st) -> Deriver st err ()
modify ((State -> State) -> Deriver State Error ())
-> (State -> State) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ \State
new -> State
new { state_dynamic :: Dynamic
state_dynamic = State -> Dynamic
state_dynamic State
st }
    a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

-- | A version of 'local' that catches exceptions and ignores any changes to
-- Collect.  This is appropriate for sub-calls that are below normal track
-- derivation.
detached_local :: (Dynamic -> Dynamic) -> Deriver a -> Deriver (Either Error a)
detached_local :: forall a.
(Dynamic -> Dynamic) -> Deriver a -> Deriver (Either Error a)
detached_local Dynamic -> Dynamic
modify_dynamic Deriver a
deriver = do
    State
st <- Deriver State Error State
forall st err. Deriver st err st
get
    let (Either Error a
result, State
_, [Msg]
logs) = State -> Deriver a -> (Either Error a, State, [Msg])
forall st err a. st -> Deriver st err a -> RunResult st err a
run
            (State
st { state_dynamic :: Dynamic
state_dynamic = Dynamic -> Dynamic
modify_dynamic (State -> Dynamic
state_dynamic State
st) }) Deriver a
deriver
    (Msg -> Deriver State Error ()) -> [Msg] -> Deriver State Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Msg -> Deriver State Error ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    Either Error a -> Deriver (Either Error a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error a
result

set_threaded :: Threaded -> Deriver ()
set_threaded :: Threaded -> Deriver State Error ()
set_threaded Threaded
threaded = (State -> State) -> Deriver State Error ()
forall st err. (st -> st) -> Deriver st err ()
modify ((State -> State) -> Deriver State Error ())
-> (State -> State) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_threaded :: Threaded
state_threaded = Threaded
threaded }

get_named_pitch :: ScoreT.PControl -> Deriver (Maybe PSignal.PSignal)
get_named_pitch :: PControl -> Deriver (Maybe PSignal)
get_named_pitch PControl
name
    | PControl
name PControl -> PControl -> Bool
forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch = PSignal -> Maybe PSignal
forall a. a -> Maybe a
Just (PSignal -> Maybe PSignal)
-> Deriver State Error PSignal -> Deriver (Maybe PSignal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dynamic -> PSignal) -> Deriver State Error PSignal
forall a. (Dynamic -> a) -> Deriver a
get_dynamic Dynamic -> PSignal
state_pitch
    | Bool
otherwise = PControl -> Map PControl PSignal -> Maybe PSignal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PControl
name (Map PControl PSignal -> Maybe PSignal)
-> Deriver State Error (Map PControl PSignal)
-> Deriver (Maybe PSignal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dynamic -> Map PControl PSignal)
-> Deriver State Error (Map PControl PSignal)
forall a. (Dynamic -> a) -> Deriver a
get_dynamic Dynamic -> Map PControl PSignal
state_pitches

-- * Collect

-- | Collect is only ever accumulated.
--
-- Direct modification would be potentially more efficient, but according to
-- profiling it doesn't make a difference.
merge_collect :: Collect -> Deriver ()
merge_collect :: Collect -> Deriver State Error ()
merge_collect Collect
c = (State -> State) -> Deriver State Error ()
forall st err. (st -> st) -> Deriver st err ()
modify ((State -> State) -> Deriver State Error ())
-> (State -> State) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_collect :: Collect
state_collect = State -> Collect
state_collect State
st Collect -> Collect -> Collect
forall a. Semigroup a => a -> a -> a
<> Collect
c }
    -- I append the Collect, which means that I wind up with the first instance
    -- for Maps with duplicate keys.  This seems a bit more intuitive than the
    -- last one.

-- | Run with an empty Collect, restore the original Collect, and return the
-- sub-deriver's Collect.
local_collect :: Deriver a -> Deriver (a, Collect)
local_collect :: forall a. Deriver a -> Deriver (a, Collect)
local_collect Deriver a
deriver = do
    Collect
old <- (State -> Collect) -> Deriver State Error Collect
forall st a err. (st -> a) -> Deriver st err a
gets State -> Collect
state_collect
    (State -> State) -> Deriver State Error ()
forall st err. (st -> st) -> Deriver st err ()
modify ((State -> State) -> Deriver State Error ())
-> (State -> State) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_collect :: Collect
state_collect = Collect
forall a. Monoid a => a
mempty }
    a
result <- Deriver a
deriver
    Collect
sub_collect <- (State -> Collect) -> Deriver State Error Collect
forall st a err. (st -> a) -> Deriver st err a
gets State -> Collect
state_collect
    (State -> State) -> Deriver State Error ()
forall st err. (st -> st) -> Deriver st err ()
modify ((State -> State) -> Deriver State Error ())
-> (State -> State) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_collect :: Collect
state_collect = Collect
old }
    (a, Collect) -> Deriver (a, Collect)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Collect
sub_collect)

-- | Modify the 'collect_warp_map' to reduce the start and end by the given
-- times.  This is useful if you're going to clip off some events.  The
-- TrackWarps, and hence playback cursor, can't know you're going to do this,
-- so you have to tell it.
trim_track_warps :: Maybe RealTime -> Maybe RealTime -> Deriver a -> Deriver a
trim_track_warps :: forall a.
Maybe RealTime -> Maybe RealTime -> Deriver a -> Deriver a
trim_track_warps Maybe RealTime
start Maybe RealTime
end = (Collect -> Collect) -> Deriver a -> Deriver a
forall a. (Collect -> Collect) -> Deriver a -> Deriver a
with_collect ((Collect -> Collect) -> Deriver a -> Deriver a)
-> (Collect -> Collect) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Collect
st -> Collect
st
    { collect_warp_map :: WarpMap
collect_warp_map = Track -> Track
trim (Track -> Track) -> WarpMap -> WarpMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Collect -> WarpMap
collect_warp_map Collect
st }
    where
    trim :: Track -> Track
trim (TrackWarp.Track RealTime
s RealTime
e Warp
warp BlockId
block_id Maybe TrackId
track_id) =
        RealTime -> RealTime -> Warp -> BlockId -> Maybe TrackId -> Track
TrackWarp.Track (RealTime -> (RealTime -> RealTime) -> Maybe RealTime -> RealTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
s (RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max RealTime
s) Maybe RealTime
start) (RealTime -> (RealTime -> RealTime) -> Maybe RealTime -> RealTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
e (RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
min RealTime
e) Maybe RealTime
end)
            Warp
warp BlockId
block_id Maybe TrackId
track_id

-- | Run the deriver and modify the Collect it returns.
with_collect :: (Collect -> Collect) -> Deriver a -> Deriver a
with_collect :: forall a. (Collect -> Collect) -> Deriver a -> Deriver a
with_collect Collect -> Collect
modify Deriver a
deriver = do
    (a
a, Collect
collect) <- Deriver a -> Deriver (a, Collect)
forall a. Deriver a -> Deriver (a, Collect)
local_collect Deriver a
deriver
    Collect -> Deriver State Error ()
merge_collect (Collect -> Collect
modify Collect
collect)
    a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | TODO this is sketchy, you're supposed to use 'merge_collect'.
modify_collect :: (Collect -> Collect) -> Deriver ()
modify_collect :: (Collect -> Collect) -> Deriver State Error ()
modify_collect Collect -> Collect
f = (State -> State) -> Deriver State Error ()
forall st err. (st -> st) -> Deriver st err ()
modify ((State -> State) -> Deriver State Error ())
-> (State -> State) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_collect :: Collect
state_collect = Collect -> Collect
f (State -> Collect
state_collect State
st) }

-- * environ

get_environ :: Deriver DeriveT.Environ
get_environ :: Deriver Environ
get_environ = (Dynamic -> Environ) -> Deriver Environ
forall a. (Dynamic -> a) -> Deriver a
get_dynamic Dynamic -> Environ
state_environ

-- | Figure out the current block and track, and record the current environ
-- in the Collect.  It only needs to be recorded once per track.
record_track_dynamic :: Dynamic -> Maybe TrackDynamic
record_track_dynamic :: Dynamic -> Maybe TrackDynamic
record_track_dynamic Dynamic
dyn = case Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of (Dynamic -> Stack
state_stack Dynamic
dyn) of
    Just (BlockId
bid, TrackId
tid) -> TrackDynamic -> Maybe TrackDynamic
forall a. a -> Maybe a
Just (TrackDynamic -> Maybe TrackDynamic)
-> TrackDynamic -> Maybe TrackDynamic
forall a b. (a -> b) -> a -> b
$! (BlockId, TrackId) -> Dynamic -> TrackDynamic
forall k a. k -> a -> Map k a
Map.singleton (BlockId
bid, TrackId
tid) (Dynamic -> TrackDynamic) -> Dynamic -> TrackDynamic
forall a b. (a -> b) -> a -> b
$!
        -- If I don't clear the inversion state, any inverting call that uses
        -- this dynamic will throw a double inversion error.  Also the function
        -- closure probably causes drag.
        Dynamic
dyn { state_inversion :: Inversion
state_inversion = Inversion
NotInverted }
    Maybe (BlockId, TrackId)
Nothing -> Maybe TrackDynamic
forall a. Maybe a
Nothing

-- | 'record_track_dynamic' for when I already know BlockId and TrackId.
record_track_dynamic_for :: BlockId -> TrackId -> Deriver ()
record_track_dynamic_for :: BlockId -> TrackId -> Deriver State Error ()
record_track_dynamic_for BlockId
block_id TrackId
track_id = do
    Dynamic
dynamic <- (State -> Dynamic) -> Deriver Dynamic
forall st a err. (st -> a) -> Deriver st err a
gets State -> Dynamic
state_dynamic
    Collect -> Deriver State Error ()
merge_collect (Collect -> Deriver State Error ())
-> Collect -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Collect
forall a. Monoid a => a
mempty
        { collect_track_dynamic :: TrackDynamic
collect_track_dynamic = (BlockId, TrackId) -> Dynamic -> TrackDynamic
forall k a. k -> a -> Map k a
Map.singleton (BlockId
block_id, TrackId
track_id) Dynamic
dynamic }

-- * misc Dynamic state

with_default_merge :: Map ScoreT.Control Merger -> Deriver a -> Deriver a
with_default_merge :: forall a. Map Control Merger -> Deriver a -> Deriver a
with_default_merge Map Control Merger
defaults = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
st -> Dynamic
st
    { state_control_merge_defaults :: Map Control Merger
state_control_merge_defaults =
        Map Control Merger
defaults Map Control Merger -> Map Control Merger -> Map Control Merger
forall a. Semigroup a => a -> a -> a
<> Dynamic -> Map Control Merger
state_control_merge_defaults Dynamic
st
    }

-- * cache

with_control_damage :: ControlDamage -> Deriver derived -> Deriver derived
with_control_damage :: forall derived. ControlDamage -> Deriver derived -> Deriver derived
with_control_damage ControlDamage
damage = (Dynamic -> Dynamic) -> Deriver derived -> Deriver derived
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
local ((Dynamic -> Dynamic) -> Deriver derived -> Deriver derived)
-> (Dynamic -> Dynamic) -> Deriver derived -> Deriver derived
forall a b. (a -> b) -> a -> b
$ \Dynamic
st ->
    Dynamic
st { state_control_damage :: ControlDamage
state_control_damage = ControlDamage
damage }

add_block_dep :: BlockId -> Deriver ()
add_block_dep :: BlockId -> Deriver State Error ()
add_block_dep BlockId
block_id = Collect -> Deriver State Error ()
merge_collect (Collect -> Deriver State Error ())
-> Collect -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Collect
forall a. Monoid a => a
mempty
    { collect_block_deps :: BlockDeps
collect_block_deps = Set BlockId -> BlockDeps
BlockDeps (BlockId -> Set BlockId
forall a. a -> Set a
Set.singleton BlockId
block_id) }

-- * ui state

get_ui_state :: (Ui.State -> a) -> Deriver a
get_ui_state :: forall a. (State -> a) -> Deriver a
get_ui_state State -> a
f = (State -> a) -> Deriver State Error a
forall st a err. (st -> a) -> Deriver st err a
gets (State -> a
f (State -> a) -> (State -> State) -> State -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constant -> State
state_ui (Constant -> State) -> (State -> Constant) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Constant
state_constant)

get_ui_config :: (UiConfig.Config -> a) -> Deriver a
get_ui_config :: forall a. (Config -> a) -> Deriver a
get_ui_config Config -> a
f = (State -> a) -> Deriver a
forall a. (State -> a) -> Deriver a
get_ui_state (Config -> a
f (Config -> a) -> (State -> Config) -> State -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Ui.state_config)

-- | Because Deriver is not a UiStateMonad.
--
-- TODO I suppose it could be, but then I'd be tempted to make
-- a ReadOnlyUiStateMonad.  And I'd have to merge the exceptions.
-- Or just rethrow, right?
get_track :: TrackId -> Deriver Track.Track
get_track :: TrackId -> Deriver Track
get_track TrackId
track_id = TrackId -> Map TrackId Track -> Deriver Track
forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a
lookup_id TrackId
track_id (Map TrackId Track -> Deriver Track)
-> Deriver State Error (Map TrackId Track) -> Deriver Track
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (State -> Map TrackId Track)
-> Deriver State Error (Map TrackId Track)
forall a. (State -> a) -> Deriver a
get_ui_state State -> Map TrackId Track
Ui.state_tracks

get_block :: BlockId -> Deriver Block.Block
get_block :: BlockId -> Deriver Block
get_block BlockId
block_id = BlockId -> Map BlockId Block -> Deriver Block
forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a
lookup_id BlockId
block_id (Map BlockId Block -> Deriver Block)
-> Deriver State Error (Map BlockId Block) -> Deriver Block
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (State -> Map BlockId Block)
-> Deriver State Error (Map BlockId Block)
forall a. (State -> a) -> Deriver a
get_ui_state State -> Map BlockId Block
Ui.state_blocks

-- | Evaluate a Ui.M computation, rethrowing any errors.
eval_ui :: CallStack.Stack => Ui.StateId a -> Deriver a
eval_ui :: forall a. Stack => StateId a -> Deriver a
eval_ui StateId a
action = do
    State
ui_state <- (State -> State) -> Deriver State
forall a. (State -> a) -> Deriver a
get_ui_state State -> State
forall a. a -> a
id
    let rethrow :: a -> Deriver a
rethrow a
exc = Text -> Deriver a
forall a. Stack => Text -> Deriver a
throw (Text -> Deriver a) -> Text -> Deriver a
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. Pretty a => a -> Text
pretty a
exc
    (Error -> Deriver a)
-> (a -> Deriver a) -> Either Error a -> Deriver a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error -> Deriver a
forall {a} {a}. Pretty a => a -> Deriver a
rethrow a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> StateId a -> Either Error a
forall a. State -> StateId a -> Either Error a
Ui.eval State
ui_state StateId a
action)

-- | Lookup @map!key@, throwing if it doesn't exist.
lookup_id :: (Ord k, Show k) => k -> Map k a -> Deriver a
lookup_id :: forall k a. (Ord k, Show k) => k -> Map k a -> Deriver a
lookup_id k
key Map k a
map = case k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
key Map k a
map of
    Maybe a
Nothing -> Text -> Deriver a
forall a. Stack => Text -> Deriver a
throw (Text -> Deriver a) -> Text -> Deriver a
forall a b. (a -> b) -> a -> b
$ Text
"unknown " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> k -> Text
forall a. Show a => a -> Text
showt k
key
    Just a
val -> a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- * stack

lookup_current_block_id :: Deriver (Maybe BlockId)
lookup_current_block_id :: Deriver (Maybe BlockId)
lookup_current_block_id = do
    Stack
stack <- Deriver Stack
get_stack
    Maybe BlockId -> Deriver (Maybe BlockId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe BlockId -> Deriver (Maybe BlockId))
-> Maybe BlockId -> Deriver (Maybe BlockId)
forall a b. (a -> b) -> a -> b
$ case [BlockId
bid | Stack.Block BlockId
bid <- Stack -> [Frame]
Stack.innermost Stack
stack] of
        [] -> Maybe BlockId
forall a. Maybe a
Nothing
        BlockId
bid : [BlockId]
_ -> BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
bid

get_current_block_id :: Deriver BlockId
get_current_block_id :: Deriver BlockId
get_current_block_id =
    Deriver BlockId
-> (BlockId -> Deriver BlockId) -> Maybe BlockId -> Deriver BlockId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Deriver BlockId
forall a. Stack => Text -> Deriver a
throw Text
"get_current_block_id: no blocks in stack") BlockId -> Deriver BlockId
forall (m :: * -> *) a. Monad m => a -> m a
return
        (Maybe BlockId -> Deriver BlockId)
-> Deriver (Maybe BlockId) -> Deriver BlockId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver (Maybe BlockId)
lookup_current_block_id

lookup_current_tracknum :: Deriver (Maybe (BlockId, TrackNum))
lookup_current_tracknum :: Deriver (Maybe (BlockId, Serial))
lookup_current_tracknum = do
    Stack
stack <- Deriver Stack
get_stack
    case Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of Stack
stack of
        Maybe (BlockId, TrackId)
Nothing -> Maybe (BlockId, Serial) -> Deriver (Maybe (BlockId, Serial))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (BlockId, Serial)
forall a. Maybe a
Nothing
        Just (BlockId
block_id, TrackId
track_id) -> do
            Serial
tracknum <- StateId Serial -> Deriver Serial
forall a. Stack => StateId a -> Deriver a
eval_ui (StateId Serial -> Deriver Serial)
-> StateId Serial -> Deriver Serial
forall a b. (a -> b) -> a -> b
$ BlockId -> TrackId -> StateId Serial
forall (m :: * -> *). M m => BlockId -> TrackId -> m Serial
Ui.get_tracknum_of BlockId
block_id TrackId
track_id
            Maybe (BlockId, Serial) -> Deriver (Maybe (BlockId, Serial))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (BlockId, Serial) -> Deriver (Maybe (BlockId, Serial)))
-> Maybe (BlockId, Serial) -> Deriver (Maybe (BlockId, Serial))
forall a b. (a -> b) -> a -> b
$ (BlockId, Serial) -> Maybe (BlockId, Serial)
forall a. a -> Maybe a
Just (BlockId
block_id, Serial
tracknum)

get_current_tracknum :: Deriver (BlockId, TrackNum)
get_current_tracknum :: Deriver (BlockId, Serial)
get_current_tracknum =
    Deriver (BlockId, Serial)
-> ((BlockId, Serial) -> Deriver (BlockId, Serial))
-> Maybe (BlockId, Serial)
-> Deriver (BlockId, Serial)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Deriver (BlockId, Serial)
forall a. Stack => Text -> Deriver a
throw Text
"get_current_tracknum") (BlockId, Serial) -> Deriver (BlockId, Serial)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (BlockId, Serial) -> Deriver (BlockId, Serial))
-> Deriver (Maybe (BlockId, Serial)) -> Deriver (BlockId, Serial)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver (Maybe (BlockId, Serial))
lookup_current_tracknum

-- | Make a quick trick block stack.
{-# SCC with_stack_block #-}
with_stack_block :: BlockId -> Deriver a -> Deriver a
with_stack_block :: forall a. BlockId -> Deriver a -> Deriver a
with_stack_block = Frame -> Deriver a -> Deriver a
forall a. Frame -> Deriver a -> Deriver a
with_stack (Frame -> Deriver a -> Deriver a)
-> (BlockId -> Frame) -> BlockId -> Deriver a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> Frame
Stack.Block

-- | Make a quick trick track stack.
{-# SCC with_stack_track #-}
with_stack_track :: TrackId -> Deriver a -> Deriver a
with_stack_track :: forall a. TrackId -> Deriver a -> Deriver a
with_stack_track = Frame -> Deriver a -> Deriver a
forall a. Frame -> Deriver a -> Deriver a
with_stack (Frame -> Deriver a -> Deriver a)
-> (TrackId -> Frame) -> TrackId -> Deriver a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackId -> Frame
Stack.Track

{-# SCC with_stack_region #-}
with_stack_region :: ScoreTime -> ScoreTime -> Deriver a -> Deriver a
with_stack_region :: forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
with_stack_region ScoreTime
s ScoreTime
e = Frame -> Deriver a -> Deriver a
forall a. Frame -> Deriver a -> Deriver a
with_stack (ScoreTime -> ScoreTime -> Frame
Stack.Region ScoreTime
s ScoreTime
e)

{-# SCC with_stack_call #-}
with_stack_call :: CallName -> Deriver a -> Deriver a
with_stack_call :: forall a. CallName -> Deriver a -> Deriver a
with_stack_call (CallName Text
name) = Frame -> Deriver a -> Deriver a
forall a. Frame -> Deriver a -> Deriver a
with_stack (Text -> Frame
Stack.Call Text
name)

{-# SCC with_stack_serial #-}
with_stack_serial :: Int -> Deriver a -> Deriver a
with_stack_serial :: forall a. Serial -> Deriver a -> Deriver a
with_stack_serial = Frame -> Deriver a -> Deriver a
forall a. Frame -> Deriver a -> Deriver a
with_stack (Frame -> Deriver a -> Deriver a)
-> (Serial -> Frame) -> Serial -> Deriver a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Serial -> Frame
Stack.Serial

with_stack :: Stack.Frame -> Deriver a -> Deriver a
with_stack :: forall a. Frame -> Deriver a -> Deriver a
with_stack Frame
frame = (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
localm ((Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Deriver Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
st -> do
    Stack
stack <- Deriver Stack
get_stack
    Bool -> Deriver State Error () -> Deriver State Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Stack -> Serial
Stack.length Stack
stack Serial -> Serial -> Bool
forall a. Ord a => a -> a -> Bool
>= Serial
max_depth) (Deriver State Error () -> Deriver State Error ())
-> Deriver State Error () -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$
        Text -> Deriver State Error ()
forall a. Stack => Text -> Deriver a
throw (Text -> Deriver State Error ()) -> Text -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Text
"call stack too deep: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Frame -> Text
forall a. Pretty a => a -> Text
pretty Frame
frame
    Dynamic -> Deriver Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic -> Deriver Dynamic) -> Dynamic -> Deriver Dynamic
forall a b. (a -> b) -> a -> b
$ Frame -> Dynamic -> Dynamic
add_stack_frame Frame
frame Dynamic
st
    where
    -- A recursive loop will result in an unfriendly hang.  So limit the total
    -- nesting depth to catch those.  I could disallow all recursion, but this
    -- is more general.
    max_depth :: Serial
max_depth = Serial
100

{- | Add a new stack frame and hash it with the random seed.

    I skip Stack.Call for seed changes.  This is so I can use calls like
    log-seed to record the seed to hardcode it later, which is the whole point
    of doing this thing where I hash on every stack frame.  Otherwise, the
    presence of the log-seed call itself would be enough to change the seed.

    In addition, calculating the seed eagerly this way is actually pretty
    expensive, since the stack is constantly being updated, so updating it
    less frequently is good for performance.  It's possible I could update
    the seed lazily to reduce this cost, but not doing something at all
    is still cheaper than lazy, and can't be accidentally forced.

    The risk is that this makes the seed too stable, and things which should
    be randomized become identical.
-}
add_stack_frame :: Stack.Frame -> Dynamic -> Dynamic
add_stack_frame :: Frame -> Dynamic -> Dynamic
add_stack_frame Frame
frame Dynamic
st = Dynamic
st
    { state_stack :: Stack
state_stack = Frame -> Stack -> Stack
Stack.add Frame
frame (Dynamic -> Stack
state_stack Dynamic
st)
    , state_environ :: Environ
state_environ = (if Frame -> Bool
should_update_seed Frame
frame then Environ -> Environ
update_seed else Environ -> Environ
forall a. a -> a
id)
        (Dynamic -> Environ
state_environ Dynamic
st)
    }
    where
    should_update_seed :: Frame -> Bool
should_update_seed (Stack.Call {}) = Bool
False
    should_update_seed Frame
_ = Bool
True
    update_seed :: Environ -> Environ
update_seed Environ
env =
        Text -> Val -> Environ -> Environ
DeriveT.insert Text
EnvKey.seed
            (Typed Double -> Val
DeriveT.VNum (Double -> Typed Double
forall a. a -> Typed a
ScoreT.untyped (Double -> Double
update Double
old))) Environ
env
        where
        old :: Double
old = case Text -> Environ -> Maybe Val
DeriveT.lookup Text
EnvKey.seed Environ
env of
            Just (DeriveT.VNum Typed Double
n) -> Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val Typed Double
n
            Maybe Val
_ -> Double
0
    update :: Double -> Double
    update :: Double -> Double
update Double
n = Serial -> Double
i2d (Serial -> Frame -> Serial
forall a. Seed a => Serial -> a -> Serial
Seed.to_seed (Double -> Serial
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
n) Frame
frame)
    -- A Double should be able to hold up to 2^52, but that's still an
    -- annoyingly large number to write in a score, so restrict it further.
    i2d :: Int -> Double
    i2d :: Serial -> Double
i2d Serial
i = Serial -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Serial
i Serial -> Serial -> Serial
forall a. Integral a => a -> a -> a
`mod` Serial
999)

get_stack :: Deriver Stack.Stack
get_stack :: Deriver Stack
get_stack = (Dynamic -> Stack) -> Deriver Stack
forall a. (Dynamic -> a) -> Deriver a
get_dynamic Dynamic -> Stack
state_stack

-- ** time and duration

-- | Times are types that can be converted to RealTime and ScoreTime.
class Time a where
    real :: a -> Deriver RealTime
    score :: a -> Deriver ScoreTime
    to_duration :: a -> DeriveT.Duration

instance Time ScoreTime where
    real :: ScoreTime -> Deriver RealTime
real = ScoreTime -> Deriver RealTime
score_to_real
    score :: ScoreTime -> Deriver ScoreTime
score = ScoreTime -> Deriver ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return
    to_duration :: ScoreTime -> Duration
to_duration = ScoreTime -> Duration
DeriveT.ScoreDuration

instance Time RealTime where
    real :: RealTime -> Deriver RealTime
real = RealTime -> Deriver RealTime
forall (m :: * -> *) a. Monad m => a -> m a
return
    score :: RealTime -> Deriver ScoreTime
score = RealTime -> Deriver ScoreTime
real_to_score
    to_duration :: RealTime -> Duration
to_duration = RealTime -> Duration
DeriveT.RealDuration

instance Time DeriveT.Duration where
    real :: Duration -> Deriver RealTime
real (DeriveT.RealDuration RealTime
t) = RealTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
real RealTime
t
    real (DeriveT.ScoreDuration ScoreTime
t) = ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
real ScoreTime
t
    score :: Duration -> Deriver ScoreTime
score (DeriveT.RealDuration RealTime
t) = RealTime -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
score RealTime
t
    score (DeriveT.ScoreDuration ScoreTime
t) = ScoreTime -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
score ScoreTime
t
    to_duration :: Duration -> Duration
to_duration = Duration -> Duration
forall a. a -> a
id

-- * warp

in_real_time :: Deriver a -> Deriver a
in_real_time :: forall a. Deriver a -> Deriver a
in_real_time = (Warp -> Warp) -> Deriver a -> Deriver a
forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp (Warp -> Warp -> Warp
forall a b. a -> b -> a
const Warp
Warp.identity)

with_warp :: (Warp.Warp -> Warp.Warp) -> Deriver a -> Deriver a
with_warp :: forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp Warp -> Warp
f = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ \Dynamic
st -> Dynamic
st { state_warp :: Warp
state_warp = Warp -> Warp
f (Dynamic -> Warp
state_warp Dynamic
st) }

get_warp :: Deriver Warp.Warp
get_warp :: Deriver Warp
get_warp = (Dynamic -> Warp) -> Deriver Warp
forall a. (Dynamic -> a) -> Deriver a
get_dynamic Dynamic -> Warp
state_warp

at :: ScoreTime -> Deriver a -> Deriver a
at :: forall a. ScoreTime -> Deriver a -> Deriver a
at ScoreTime
shift = (Warp -> Warp) -> Deriver a -> Deriver a
forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp ((Warp -> Warp) -> Deriver a -> Deriver a)
-> (Warp -> Warp) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ ScoreTime -> Warp -> Warp
Warp.shift ScoreTime
shift

stretch :: ScoreTime -> Deriver a -> Deriver a
stretch :: forall a. ScoreTime -> Deriver a -> Deriver a
stretch ScoreTime
factor = (Warp -> Warp) -> Deriver a -> Deriver a
forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp ((Warp -> Warp) -> Deriver a -> Deriver a)
-> (Warp -> Warp) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ ScoreTime -> Warp -> Warp
Warp.stretch ScoreTime
factor

-- | 'at' and 'stretch' in one.  It's a little more efficient than using them
-- separately.  The order is stretch, then shift.
place :: ScoreTime -> ScoreTime -> Deriver a -> Deriver a
place :: forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
place ScoreTime
shift ScoreTime
stretch = (Warp -> Warp) -> Deriver a -> Deriver a
forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp ((Warp -> Warp) -> Deriver a -> Deriver a)
-> (Warp -> Warp) -> Deriver a -> Deriver a
forall a b. (a -> b) -> a -> b
$ ScoreTime -> Warp -> Warp
Warp.stretch ScoreTime
stretch (Warp -> Warp) -> (Warp -> Warp) -> Warp -> Warp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Warp -> Warp
Warp.shift ScoreTime
shift
    -- Warp.stretch and Warp.shift look like they're in the wrong order here,
    -- but they're not.  "Derive.Warp" for details.

-- | Compose warps.
warp :: Warp.Warp -> Deriver a -> Deriver a
warp :: forall a. Warp -> Deriver a -> Deriver a
warp Warp
w
    | Warp -> Bool
Warp.is_identity Warp
w = Deriver a -> Deriver a
forall a. a -> a
id
    | Bool
otherwise = (Warp -> Warp) -> Deriver a -> Deriver a
forall a. (Warp -> Warp) -> Deriver a -> Deriver a
with_warp (Warp -> Warp -> Warp
`Warp.compose` Warp
w)

-- ** track warp

-- | Start a new track warp for the current block_id.
--
-- This must be called for each block, and it must be called after the tempo is
-- warped for that block so it can install the new warp.
add_new_track_warp :: Maybe TrackId -> Deriver ()
add_new_track_warp :: Maybe TrackId -> Deriver State Error ()
add_new_track_warp Maybe TrackId
maybe_track_id = do
    Stack
stack <- Deriver Stack
get_stack
    BlockId
block_id <- Deriver BlockId
get_current_block_id
    RealTime
start <- ScoreTime -> Deriver RealTime
score_to_real ScoreTime
0
    -- Use block_event_end instead of block_logical_range.  Otherwise, the play
    -- monitor can't go past the end of the ruler, while the player is
    -- perfectly happy to do so.
    RealTime
end <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
real (ScoreTime -> Deriver RealTime)
-> Deriver ScoreTime -> Deriver RealTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId -> Deriver ScoreTime
block_event_end BlockId
block_id
    Warp
warp <- Deriver Warp
get_warp
    let track :: Track
track = RealTime -> RealTime -> Warp -> BlockId -> Maybe TrackId -> Track
TrackWarp.Track RealTime
start RealTime
end Warp
warp BlockId
block_id Maybe TrackId
maybe_track_id
    Collect -> Deriver State Error ()
merge_collect (Collect -> Deriver State Error ())
-> Collect -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Collect
forall a. Monoid a => a
mempty { collect_warp_map :: WarpMap
collect_warp_map = Stack -> Track -> WarpMap
forall k a. k -> a -> Map k a
Map.singleton Stack
stack Track
track }

-- | Sub-derived blocks are stretched according to their length, and this
-- function defines the length of a block.  This is therefore the logical
-- duration of the block, which may be shorter or lorger than the end of the
-- last event, or the ruler.
block_logical_range :: BlockId -> Deriver (TrackTime, TrackTime)
block_logical_range :: BlockId -> Deriver (ScoreTime, ScoreTime)
block_logical_range = StateId (ScoreTime, ScoreTime) -> Deriver (ScoreTime, ScoreTime)
forall a. Stack => StateId a -> Deriver a
eval_ui (StateId (ScoreTime, ScoreTime) -> Deriver (ScoreTime, ScoreTime))
-> (BlockId -> StateId (ScoreTime, ScoreTime))
-> BlockId
-> Deriver (ScoreTime, ScoreTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> StateId (ScoreTime, ScoreTime)
forall (m :: * -> *). M m => BlockId -> m (ScoreTime, ScoreTime)
Ui.block_logical_range

-- | Get the duration of the block according to the last event.
block_event_end :: BlockId -> Deriver ScoreTime
block_event_end :: BlockId -> Deriver ScoreTime
block_event_end = StateId ScoreTime -> Deriver ScoreTime
forall a. Stack => StateId a -> Deriver a
eval_ui (StateId ScoreTime -> Deriver ScoreTime)
-> (BlockId -> StateId ScoreTime) -> BlockId -> Deriver ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> StateId ScoreTime
forall (m :: * -> *). M m => BlockId -> m ScoreTime
Ui.block_event_end


-- * track

-- | The deriver strips out tracks that can't be derived because they have no
-- notes.  But that means the track warps and track dynamics aren't recorded,
-- which means they don't have tempo or a playback monitor, which makes them
-- annoying.
record_empty_tracks :: [TrackId] -> Deriver ()
record_empty_tracks :: [TrackId] -> Deriver State Error ()
record_empty_tracks [] = () -> Deriver State Error ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
record_empty_tracks [TrackId]
track_ids = do
    BlockId
block_id <- Deriver BlockId
get_current_block_id
    (TrackId -> Deriver State Error ())
-> [TrackId] -> Deriver State Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BlockId -> TrackId -> Deriver State Error ()
record_empty_track BlockId
block_id) [TrackId]
track_ids

record_empty_track :: BlockId -> TrackId -> Deriver ()
record_empty_track :: BlockId -> TrackId -> Deriver State Error ()
record_empty_track BlockId
block_id TrackId
track_id =
    BlockId -> TrackId -> Deriver State Error ()
record_track_dynamic_for BlockId
block_id TrackId
track_id

-- * ControlFunction

get_control_function_dynamic :: Deriver DeriveT.Dynamic
get_control_function_dynamic :: Deriver Dynamic
get_control_function_dynamic = do
    Marklists
ruler <- Deriver Marklists
get_ruler
    State
state <- Deriver State Error State
forall st err. Deriver st err st
get
    Dynamic -> Deriver Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic -> Deriver Dynamic) -> Dynamic -> Deriver Dynamic
forall a b. (a -> b) -> a -> b
$ Marklists -> Dynamic -> Serial -> Dynamic
convert_dynamic Marklists
ruler (State -> Dynamic
state_dynamic State
state)
        (Threaded -> Serial
state_event_serial (State -> Threaded
state_threaded State
state))

convert_dynamic :: Ruler.Marklists -> Dynamic -> Stack.Serial
    -> DeriveT.Dynamic
convert_dynamic :: Marklists -> Dynamic -> Serial -> Dynamic
convert_dynamic Marklists
ruler Dynamic
dyn Serial
serial = DeriveT.Dynamic
    { dyn_controls :: ControlMap
dyn_controls = Dynamic -> ControlMap
state_controls Dynamic
dyn
    , dyn_control_functions :: ControlFunctionMap
dyn_control_functions = Dynamic -> ControlFunctionMap
state_control_functions Dynamic
dyn
    , dyn_pitches :: Map PControl PSignal
dyn_pitches = Dynamic -> Map PControl PSignal
state_pitches Dynamic
dyn
    , dyn_pitch :: PSignal
dyn_pitch = Dynamic -> PSignal
state_pitch Dynamic
dyn
    , dyn_environ :: Environ
dyn_environ = Dynamic -> Environ
state_environ Dynamic
dyn
    , dyn_event_serial :: Serial
dyn_event_serial = Serial
serial
    , dyn_warp :: Warp
dyn_warp = Dynamic -> Warp
state_warp Dynamic
dyn
    , dyn_ruler :: Marklists
dyn_ruler = Marklists
ruler
    }

-- | Get the 'Ruler.meter' marklists, if there is a ruler track here.  This
-- is called in all contexts, due to 'control_at', so it has to be careful
-- to not require a ruler.
get_ruler :: Deriver Ruler.Marklists
get_ruler :: Deriver Marklists
get_ruler = Deriver (Maybe (BlockId, Serial))
lookup_current_tracknum Deriver (Maybe (BlockId, Serial))
-> (Maybe (BlockId, Serial) -> Deriver Marklists)
-> Deriver Marklists
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (BlockId, Serial)
Nothing -> Marklists -> Deriver Marklists
forall (m :: * -> *) a. Monad m => a -> m a
return Marklists
forall a. Monoid a => a
mempty
    Just (BlockId
block_id, Serial
tracknum) -> do
        State
state <- (State -> State) -> Deriver State
forall a. (State -> a) -> Deriver a
get_ui_state State -> State
forall a. a -> a
id
        Marklists -> Deriver Marklists
forall (m :: * -> *) a. Monad m => a -> m a
return (Marklists -> Deriver Marklists) -> Marklists -> Deriver Marklists
forall a b. (a -> b) -> a -> b
$ (Error -> Marklists)
-> (Marklists -> Marklists) -> Either Error Marklists -> Marklists
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Marklists -> Error -> Marklists
forall a b. a -> b -> a
const Marklists
forall a. Monoid a => a
mempty) Marklists -> Marklists
forall a. a -> a
id (Either Error Marklists -> Marklists)
-> Either Error Marklists -> Marklists
forall a b. (a -> b) -> a -> b
$ State -> StateId Marklists -> Either Error Marklists
forall a. State -> StateId a -> Either Error a
Ui.eval State
state (StateId Marklists -> Either Error Marklists)
-> StateId Marklists -> Either Error Marklists
forall a b. (a -> b) -> a -> b
$ do
            RulerId
ruler_id <- RulerId -> Maybe RulerId -> RulerId
forall a. a -> Maybe a -> a
fromMaybe RulerId
Ui.no_ruler (Maybe RulerId -> RulerId)
-> StateT Identity (Maybe RulerId) -> StateT Identity RulerId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                BlockId -> Serial -> StateT Identity (Maybe RulerId)
forall (m :: * -> *). M m => BlockId -> Serial -> m (Maybe RulerId)
Ui.ruler_track_at BlockId
block_id Serial
tracknum
            Ruler -> Marklists
Ruler.ruler_marklists (Ruler -> Marklists) -> StateT Identity Ruler -> StateId Marklists
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RulerId -> StateT Identity Ruler
forall (m :: * -> *). M m => RulerId -> m Ruler
Ui.get_ruler RulerId
ruler_id


-- * Threaded

modify_threaded :: (Threaded -> Threaded) -> Deriver ()
modify_threaded :: (Threaded -> Threaded) -> Deriver State Error ()
modify_threaded Threaded -> Threaded
f = (State -> State) -> Deriver State Error ()
forall st err. (st -> st) -> Deriver st err ()
modify ((State -> State) -> Deriver State Error ())
-> (State -> State) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ \State
state -> State
state
    { state_threaded :: Threaded
state_threaded = Threaded -> Threaded
f (State -> Threaded
state_threaded State
state) }

-- | Increment 'state_event_serial'.
increment_event_serial :: Deriver ()
increment_event_serial :: Deriver State Error ()
increment_event_serial = (Threaded -> Threaded) -> Deriver State Error ()
modify_threaded ((Threaded -> Threaded) -> Deriver State Error ())
-> (Threaded -> Threaded) -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ \Threaded
threaded -> Threaded
threaded
    { state_event_serial :: Serial
state_event_serial = Threaded -> Serial
state_event_serial Threaded
threaded Serial -> Serial -> Serial
forall a. Num a => a -> a -> a
+ Serial
1 }


-- * misc

-- | Am I deriving the toplevel block?
is_root_block :: Deriver Bool
is_root_block :: Deriver Bool
is_root_block = do
    Stack
stack <- Deriver Stack
get_stack
    let blocks :: [BlockId]
blocks = [BlockId
bid | Stack.Block BlockId
bid <- Stack -> [Frame]
Stack.outermost Stack
stack]
    Bool -> Deriver Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Deriver Bool) -> Bool -> Deriver Bool
forall a b. (a -> b) -> a -> b
$ case [BlockId]
blocks of
        [] -> Bool
True
        [BlockId
_] -> Bool
True
        [BlockId]
_ -> Bool
False