-- 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 for Cmds that want to peek into the derived score for
    whatever reason.  Normally the flow of information goes from Cmd -> Derive
    -> Perform, but this module is for those cases when Cmd wants to know
    about the results of later stages.
-}
module Cmd.Perf where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Tree as Tree

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Trees as Trees

import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.PlayUtil as PlayUtil
import qualified Derive.C.Prelude.Block as Prelude.Block
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.EvalTrack as EvalTrack
import qualified Derive.Expr as Expr
import qualified Derive.LEvent as LEvent
import qualified Derive.Note
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Scale as Scale
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stream as Stream
import qualified Derive.TrackWarp as TrackWarp
import qualified Derive.Typecheck as Typecheck

import qualified Midi.Midi as Midi
import qualified Perform.Pitch as Pitch
import qualified Perform.Transport as Transport
import qualified Ui.Block as Block
import qualified Ui.Event as Event
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


get :: Cmd.M m => BlockId -> m Cmd.Performance
get :: forall (m :: * -> *). M m => BlockId -> m Performance
get BlockId
block_id = forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"no performance for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
Cmd.lookup_performance BlockId
block_id

get_current :: Cmd.M m => BlockId -> m Cmd.Performance
get_current :: forall (m :: * -> *). M m => BlockId -> m Performance
get_current BlockId
block_id =
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"no current performance for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (PlayState -> Map BlockId Performance
Cmd.state_current_performance forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
Cmd.state_play)

lookup_root :: Cmd.M m => m (Maybe Cmd.Performance)
lookup_root :: forall (m :: * -> *). M m => m (Maybe Performance)
lookup_root = forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm forall (m :: * -> *). M m => m (Maybe BlockId)
Ui.lookup_root_id forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
Cmd.lookup_performance

get_root :: Cmd.M m => m Cmd.Performance
get_root :: forall (m :: * -> *). M m => m Performance
get_root = forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"no root performance" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe Performance)
lookup_root

-- * derive

-- | Specialized version of 'derive_expr' for note calls with no arguments.
derive_note_call :: Cmd.M m => BlockId -> TrackId -> TrackTime
    -> Expr.Symbol -> m (Either Text [Score.Event], [Log.Msg])
derive_note_call :: forall (m :: * -> *).
M m =>
BlockId
-> TrackId -> TrackTime -> Symbol -> m (Either Text [Event], [Msg])
derive_note_call BlockId
block_id TrackId
track_id TrackTime
pos Symbol
call =
    forall (m :: * -> *) d.
(M m, CallableExpr d) =>
BlockId
-> TrackId -> TrackTime -> Expr -> m (Either Text [d], [Msg])
derive_expr BlockId
block_id TrackId
track_id TrackTime
pos (forall val. Symbol -> Expr val
Expr.generator0 Symbol
call)

-- | Derive an expression.
derive_expr :: (Cmd.M m, Derive.CallableExpr d) => BlockId -> TrackId
    -> TrackTime -> DeriveT.Expr -> m (Either Text [d], [Log.Msg])
derive_expr :: forall (m :: * -> *) d.
(M m, CallableExpr d) =>
BlockId
-> TrackId -> TrackTime -> Expr -> m (Either Text [d], [Msg])
derive_expr BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr = do
    (Either Text (Stream d)
result, [Msg]
logs) <- forall (m :: * -> *) a.
M m =>
BlockId -> TrackId -> Deriver a -> m (Either Text a, [Msg])
derive_at BlockId
block_id TrackId
track_id
        (forall d.
CallableExpr d =>
Bool -> TrackTime -> TrackTime -> Expr -> Deriver (Stream d)
Eval.eval_one_at Bool
False TrackTime
pos TrackTime
1 Expr
expr)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either Text (Stream d)
result of
        Left Text
err -> (forall a b. a -> Either a b
Left Text
err, [Msg]
logs)
        Right Stream d
stream -> (forall a b. b -> Either a b
Right [d]
events, [Msg]
derive_logs forall a. [a] -> [a] -> [a]
++ [Msg]
logs)
            where ([d]
events, [Msg]
derive_logs) = forall a. Stream a -> ([a], [Msg])
Stream.partition Stream d
stream

-- | Run an ad-hoc derivation in the context of the given track.
derive_at :: Cmd.M m => BlockId -> TrackId
    -> Derive.Deriver a -> m (Either Text a, [Log.Msg])
derive_at :: forall (m :: * -> *) a.
M m =>
BlockId -> TrackId -> Deriver a -> m (Either Text a, [Msg])
derive_at BlockId
block_id TrackId
track_id =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
M m =>
BlockId -> TrackId -> Deriver a -> m (Either Error a, [Msg])
derive_at_exc BlockId
block_id TrackId
track_id

derive_at_exc :: Cmd.M m => BlockId -> TrackId
    -> Derive.Deriver a -> m (Either Derive.Error a, [Log.Msg])
derive_at_exc :: forall (m :: * -> *) a.
M m =>
BlockId -> TrackId -> Deriver a -> m (Either Error a, [Msg])
derive_at_exc BlockId
block_id TrackId
track_id Deriver a
deriver = do
    State
ui_state <- forall (m :: * -> *). M m => m State
Ui.get
    (Constant
constant, InstrumentAliases
aliases) <- forall (m :: * -> *).
M m =>
State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
PlayUtil.get_constant State
ui_state forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    Dynamic
dynamic <- forall a. a -> Maybe a -> a
fromMaybe (InstrumentAliases -> Dynamic
PlayUtil.initial_dynamic InstrumentAliases
aliases) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *). M m => Track -> m (Maybe Dynamic)
find_dynamic (BlockId
block_id, forall a. a -> Maybe a
Just TrackId
track_id)
    let (Either Error a
val, State
_, [Msg]
logs) = forall a. Constant -> Dynamic -> Deriver a -> RunResult a
PlayUtil.run_with_constant Constant
constant Dynamic
dynamic Deriver a
deriver
    forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error a
val, [Msg]
logs)

-- | This is like 'derive_at_exc', except with the minimal dependencies
-- needed to run a derive.
mini_derive :: Ui.State -- ^ for instrument allocations and because derivers
    -- have access to Ui.State
    -> Cmd.Config -- ^ for instrument db and builtins
    -> Derive.Builtins -> Derive.InstrumentAliases -- ^ from parsed ky
    -> Derive.Deriver a -> (Either Derive.Error a, [Log.Msg])
mini_derive :: forall a.
State
-> Config
-> Builtins
-> InstrumentAliases
-> Deriver a
-> (Either Error a, [Msg])
mini_derive State
ui_state Config
cmd_config Builtins
builtins InstrumentAliases
aliases Deriver a
deriver = (Either Error a
val, [Msg]
logs)
    where
    (Either Error a
val, State
_, [Msg]
logs) = forall a. Constant -> Dynamic -> Deriver a -> RunResult a
PlayUtil.run_with_constant Constant
constant
        (InstrumentAliases -> Dynamic
PlayUtil.initial_dynamic InstrumentAliases
aliases) Deriver a
deriver
    constant :: Constant
constant = State -> Config -> Builtins -> Cache -> ScoreDamage -> Constant
PlayUtil.initial_constant State
ui_state Config
cmd_config Builtins
builtins
        forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

-- | Like 'derive_at', but write logs and throw on a Left.
derive_at_throw :: Cmd.M m => BlockId -> TrackId -> Derive.Deriver a -> m a
derive_at_throw :: forall (m :: * -> *) a.
M m =>
BlockId -> TrackId -> Deriver a -> m a
derive_at_throw BlockId
block_id TrackId
track_id Deriver a
deriver = do
    (Either Text a
result, [Msg]
logs) <- forall (m :: * -> *) a.
M m =>
BlockId -> TrackId -> Deriver a -> m (Either Text a, [Msg])
derive_at BlockId
block_id TrackId
track_id Deriver a
deriver
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    let prefix :: Text
prefix = Text
"derive_at " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackId
track_id
    forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right ((Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) Either Text a
result

-- | Return the NoteDeriver of a particular event on a particular track,
-- or Nothing if the track isn't a NoteTrack.
lookup_note_deriver :: Cmd.M m => BlockId -> TrackId -> Event.Event
    -> m (Maybe Derive.NoteDeriver)
lookup_note_deriver :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> Event -> m (Maybe NoteDeriver)
lookup_note_deriver BlockId
block_id TrackId
track_id Event
event = do
    Tree.Node Track
track [Tree Track]
subs <- forall (m :: * -> *). M m => BlockId -> TrackId -> m (Tree Track)
find_track BlockId
block_id TrackId
track_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Text -> Type
ParseTitle.track_type (Track -> Text
TrackTree.track_title Track
track) of
        Type
ParseTitle.NoteTrack ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall d.
CallableExpr d =>
TrackInfo d -> Event -> Deriver (Stream d)
derive_event (Track -> [Tree Track] -> TrackInfo Event
Derive.Note.track_info Track
track [Tree Track]
subs) Event
event
        Type
_ -> forall a. Maybe a
Nothing

derive_event :: Derive.CallableExpr d => EvalTrack.TrackInfo d -> Event.Event
    -> Derive.Deriver (Stream.Stream d)
derive_event :: forall d.
CallableExpr d =>
TrackInfo d -> Event -> Deriver (Stream d)
derive_event TrackInfo d
tinfo Event
event = forall d.
CallableExpr d =>
Context d -> Event -> Deriver (Stream d)
EvalTrack.derive_event forall {val}. Context val
ctx Event
event
    where ctx :: Context val
ctx = forall a val.
TrackInfo a
-> Maybe val -> [Event] -> Event -> [Event] -> Context val
EvalTrack.context TrackInfo d
tinfo forall a. Maybe a
Nothing [] Event
event []
    -- TODO get prev and next events
    -- Also, BlockUtil does 'Derive.with_val EnvKey.block_end' and possibly
    -- does Tempo.with_tempo.  If those things turn out to be important,
    -- I should be able to factor that out of BlockUtil.

find_track :: Cmd.M m => BlockId -> TrackId -> m TrackTree.EventsNode
find_track :: forall (m :: * -> *). M m => BlockId -> TrackId -> m (Tree Track)
find_track BlockId
block_id TrackId
track_id = do
    [Tree Track]
tree <- forall (m :: * -> *). M m => BlockId -> m [Tree Track]
TrackTree.block_events_tree BlockId
block_id
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"find_track: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackId
track_id forall a. Semigroup a => a -> a -> a
<> Text
" not in " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id) forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [Tree a] -> Maybe (Tree a)
Trees.find ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TrackId
track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Maybe TrackId
TrackTree.track_id) [Tree Track]
tree

-- | Get the environment established by 'Ui.config_global_transform'.
global_environ :: Cmd.M m => m Env.Environ
global_environ :: forall (m :: * -> *). M m => m Environ
global_environ = do
    (Either Error (Stream Event)
result, State
_, [Msg]
logs) <- forall (m :: * -> *) a.
M m =>
Cache -> ScoreDamage -> Deriver a -> m (RunResult a)
PlayUtil.run forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty NoteDeriver
smuggle_environ
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    [Event]
events <- forall (m :: * -> *) a. LogMonad m => Stream a -> m [a]
Stream.write_logs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. Pretty a => a -> Text
pretty Either Error (Stream Event)
result
    Event
event <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"Perf.global_environ: expected a single Event" forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> Maybe a
Lists.head [Event]
events
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Event -> Environ
Score.event_environ Event
event

-- | Smuggle the environ out in an event.  It's annoying to require such
-- shennanigans, rationale in NOTE [transform-without-derive-callable].
smuggle_environ :: Derive.NoteDeriver
smuggle_environ :: NoteDeriver
smuggle_environ = NoteDeriver -> NoteDeriver
Prelude.Block.global_transform forall a b. (a -> b) -> a -> b
$ do
    Environ
env <- forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Environ
Derive.state_environ
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. a -> Stream a
Stream.from_event forall a b. (a -> b) -> a -> b
$!
        Event
Score.empty_event { event_environ :: Environ
Score.event_environ = Environ
env }

{- NOTE [transform-without-derive-callable]

    It seems like there should be a way to run a transform without the
    Derive.CallableExpr restriction, which in turn constrains the return type.

    First I need to specify which namespace of transformers to look in, but the
    underlying problem is that e.g. Derive.Transformer Score.Event works with
    Score.Events.  There is a class of them that are agnostic since they only
    change the environ, but some of them do postproc.  I don't have a separate
    namespace for those, so it's impossible to evaluate only them.
-}

-- | A cheap quick derivation that sets up the correct initial state, but
-- runs without the cache and throws away any logs.
derive :: Cmd.M m => Derive.Deriver a -> m (Either Text a)
derive :: forall (m :: * -> *) a. M m => Deriver a -> m (Either Text a)
derive Deriver a
deriver = do
    (Either Error a
val, State
_, [Msg]
_) <- forall (m :: * -> *) a.
M m =>
Cache -> ScoreDamage -> Deriver a -> m (RunResult a)
PlayUtil.run forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Deriver a
deriver
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either Error a
val of
        Left Error
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Error
err
        Right a
val -> forall a b. b -> Either a b
Right a
val

-- * perform

perform :: Cmd.M m => [Score.Event] -> m ([Midi.WriteMessage], [Log.Msg])
perform :: forall (m :: * -> *). M m => [Event] -> m ([WriteMessage], [Msg])
perform = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall d. [LEvent d] -> ([d], [Msg])
LEvent.partition forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => [Event] -> m MidiEvents
PlayUtil.perform_raw
    -- TODO this is midi only, discards sc

-- * environ

-- | Functions that look in the saved Dynamic use this as a key.
--
-- If the TrackId is Nothing, take any old Dynamic found on the given block.
type Track = (BlockId, Maybe TrackId)

{- | Get the scale in scope in a certain track on a certain block.

    This tries really really hard to find a ScaleId.  The reason is that pitch
    track entry uses it to insert pitch names, and if it gets the scale wrong
    it inserts bogus pitches.  I can't rely on 'lookup_val' because a new
    track has never been derived and thus has no Dynamic.
-}
get_scale_id :: Cmd.M m => Track -> m Pitch.ScaleId
get_scale_id :: forall (m :: * -> *). M m => Track -> m ScaleId
get_scale_id track :: Track
track@(BlockId
block_id, Maybe TrackId
maybe_track_id) =
    -- Did you know there are so many places to find a ScaleId?  Why are
    -- there so many places?
    (forall a. a -> Maybe a -> a
fromMaybe (Text -> ScaleId
Pitch.ScaleId Text
Config.default_scale_id) <$>) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
firstJust
        (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe ScaleId)
scale_from_titles BlockId
block_id) Maybe TrackId
maybe_track_id) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
firstJust (forall (m :: * -> *). M m => Track -> m (Maybe ScaleId)
find_scale_id Track
track) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- Look in Dynamic, if the new track hasn't been derived, look in GLOBAL.
lookup_scale2 :: Cmd.M m => Track -> m (Maybe Scale.Scale)
lookup_scale2 :: forall (m :: * -> *). M m => Track -> m (Maybe Scale)
lookup_scale2 (BlockId
block_id, Maybe TrackId
mb_track_id) = forall a. Stack => a
undefined

find_scale_id :: Cmd.M m => Track -> m (Maybe Pitch.ScaleId)
find_scale_id :: forall (m :: * -> *). M m => Track -> m (Maybe ScaleId)
find_scale_id (BlockId
block_id, Maybe TrackId
maybe_track_id) = (Maybe Str -> Maybe ScaleId
to_scale_id <$>) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
firstJust (forall {m :: * -> *} {a}.
(M m, Typecheck a) =>
Maybe TrackId -> m (Maybe a)
lookup Maybe TrackId
maybe_track_id) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
firstJust m (Maybe Str)
lookup_parents forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
firstJust (forall {m :: * -> *} {a}.
(M m, Typecheck a) =>
Maybe TrackId -> m (Maybe a)
lookup forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
firstJust (forall (m :: * -> *) a.
(M m, Typecheck a) =>
Text -> Environ -> m (Maybe a)
lookup_environ_val Text
EnvKey.scale forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m Environ
global_environ) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    where
    to_scale_id :: Maybe Str -> Maybe ScaleId
to_scale_id = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Str -> ScaleId
Expr.str_to_scale_id
    lookup :: Maybe TrackId -> m (Maybe a)
lookup Maybe TrackId
maybe_track_id = forall (m :: * -> *) a.
(M m, Typecheck a) =>
Track -> Text -> m (Maybe a)
lookup_val (BlockId
block_id, Maybe TrackId
maybe_track_id) Text
EnvKey.scale
    lookup_parents :: m (Maybe Str)
lookup_parents = case Maybe TrackId
maybe_track_id of
        Maybe TrackId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just TrackId
track_id -> do
            [TrackId]
parents <- forall a b. (a -> b) -> [a] -> [b]
map TrackInfo -> TrackId
Ui.track_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe ([TrackInfo], [TrackInfo]))
TrackTree.parents_children_of BlockId
block_id TrackId
track_id
            forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {a}.
(M m, Typecheck a) =>
Maybe TrackId -> m (Maybe a)
lookup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) [TrackId]
parents

get_scale :: Cmd.M m => Track -> m Scale.Scale
get_scale :: forall (m :: * -> *). M m => Track -> m Scale
get_scale Track
track = do
    ScaleId
scale_id <- forall (m :: * -> *). M m => Track -> m ScaleId
get_scale_id Track
track
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"get_scale: can't find " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ScaleId
scale_id)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => Track -> ScaleId -> m (Maybe Scale)
lookup_scale Track
track ScaleId
scale_id

lookup_scale :: Cmd.M m => Track -> Pitch.ScaleId -> m (Maybe Scale.Scale)
lookup_scale :: forall (m :: * -> *). M m => Track -> ScaleId -> m (Maybe Scale)
lookup_scale Track
track ScaleId
scale_id = do
    Environ
env <- forall (m :: * -> *). M m => Track -> m Environ
get_environ Track
track
    forall (m :: * -> *). M m => Environ -> ScaleId -> m (Maybe Scale)
lookup_scale_env Environ
env ScaleId
scale_id

lookup_scale_env :: Cmd.M m => Env.Environ -> Pitch.ScaleId
    -> m (Maybe Scale.Scale)
lookup_scale_env :: forall (m :: * -> *). M m => Environ -> ScaleId -> m (Maybe Scale)
lookup_scale_env Environ
env ScaleId
scale_id = case Environ -> ScaleId -> Maybe (Either PitchError Scale)
lookup Environ
env ScaleId
scale_id of
    Maybe (Either PitchError Scale)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just (Left PitchError
err) -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
"lookup " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ScaleId
scale_id forall a. Semigroup a => a -> a -> a
<> Text
": "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty PitchError
err
    Just (Right Scale
scale) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Scale
scale
    where
    Derive.LookupScale Environ -> ScaleId -> Maybe (Either PitchError Scale)
lookup = LookupScale
Cmd.lookup_scale

-- | Try to get a scale from the titles of the parents of the given track.
scale_from_titles :: Ui.M m => BlockId -> TrackId -> m (Maybe Pitch.ScaleId)
scale_from_titles :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe ScaleId)
scale_from_titles BlockId
block_id TrackId
track_id = do
    [TrackInfo]
tracks <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe ([TrackInfo], [TrackInfo]))
TrackTree.parents_children_of BlockId
block_id TrackId
track_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TrackInfo -> Maybe ScaleId
scale_of [TrackInfo]
tracks
    where
    scale_of :: TrackInfo -> Maybe ScaleId
scale_of TrackInfo
track = case Text -> Maybe ScaleId
ParseTitle.title_to_scale (TrackInfo -> Text
Ui.track_title TrackInfo
track) of
        Just ScaleId
scale_id | ScaleId
scale_id forall a. Eq a => a -> a -> Bool
/= ScaleId
Pitch.empty_scale -> forall a. a -> Maybe a
Just ScaleId
scale_id
        Maybe ScaleId
_ -> forall a. Maybe a
Nothing

-- | Find the instrument in scope.
lookup_instrument :: Cmd.M m => Track -> m (Maybe ScoreT.Instrument)
lookup_instrument :: forall (m :: * -> *). M m => Track -> m (Maybe Instrument)
lookup_instrument Track
track = forall (m :: * -> *) a.
(M m, Typecheck a) =>
Track -> Text -> m (Maybe a)
lookup_val Track
track Text
EnvKey.instrument

-- | Lookup value from the deriver's EnvKey at the given block and (possibly)
-- track.  See 'Derive.TrackDynamic' for details on the limitations here.
--
-- The value is taken first from the root performance, and then the given
-- block's performance if not present in the root performance.  This is so
-- that blocks which are not called from the root at all will still have
-- environ values.
lookup_val :: (Cmd.M m, Typecheck.Typecheck a) => Track -> Env.Key
    -> m (Maybe a)
lookup_val :: forall (m :: * -> *) a.
(M m, Typecheck a) =>
Track -> Text -> m (Maybe a)
lookup_val Track
track Text
name = forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *). M m => Track -> m (Maybe Environ)
lookup_environ Track
track) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(M m, Typecheck a) =>
Text -> Environ -> m (Maybe a)
lookup_environ_val Text
name

lookup_environ_val :: (Ui.M m, Typecheck.Typecheck a) =>
    Env.Key -> Env.Environ -> m (Maybe a)
lookup_environ_val :: forall (m :: * -> *) a.
(M m, Typecheck a) =>
Text -> Environ -> m (Maybe a)
lookup_environ_val Text
name Environ
env =
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"Perf.lookup_environ_val: "<>)) forall (m :: * -> *) a. Monad m => a -> m a
return
        (forall a. Typecheck a => Text -> Environ -> Either Text (Maybe a)
Env.checked_val Text
name Environ
env)

lookup_environ :: Cmd.M m => Track -> m (Maybe Env.Environ)
lookup_environ :: forall (m :: * -> *). M m => Track -> m (Maybe Environ)
lookup_environ Track
track = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dynamic -> Environ
Derive.state_environ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => Track -> m (Maybe Dynamic)
find_dynamic Track
track

get_environ :: Cmd.M m => Track -> m Env.Environ
get_environ :: forall (m :: * -> *). M m => Track -> m Environ
get_environ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => Track -> m (Maybe Environ)
lookup_environ

-- | Try to find the Dynamic for the given block and track, first looking in
-- the root performance, and then in the block's performance.
find_dynamic :: Cmd.M m => Track -> m (Maybe Derive.Dynamic)
find_dynamic :: forall (m :: * -> *). M m => Track -> m (Maybe Dynamic)
find_dynamic Track
track = forall (m :: * -> *). M m => Track -> m (Maybe Dynamic)
lookup_root_dynamic Track
track forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Dynamic
dyn -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Dynamic
dyn
    Maybe Dynamic
Nothing -> forall (m :: * -> *). M m => BlockId -> Track -> m (Maybe Dynamic)
lookup_dynamic (forall a b. (a, b) -> a
fst Track
track) Track
track

lookup_root_dynamic :: Cmd.M m => Track -> m (Maybe Derive.Dynamic)
lookup_root_dynamic :: forall (m :: * -> *). M m => Track -> m (Maybe Dynamic)
lookup_root_dynamic Track
track =
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm forall (m :: * -> *). M m => m (Maybe BlockId)
Ui.lookup_root_id forall a b. (a -> b) -> a -> b
$ \BlockId
root_id -> forall (m :: * -> *). M m => BlockId -> Track -> m (Maybe Dynamic)
lookup_dynamic BlockId
root_id Track
track

lookup_dynamic :: Cmd.M m => BlockId -> Track -> m (Maybe Derive.Dynamic)
lookup_dynamic :: forall (m :: * -> *). M m => BlockId -> Track -> m (Maybe Dynamic)
lookup_dynamic BlockId
perf_block_id (BlockId
block_id, Maybe TrackId
maybe_track_id) =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (forall {b}. Map (BlockId, TrackId) b -> Maybe b
lookup forall b c a. (b -> c) -> (a -> b) -> a -> c
. Performance -> TrackDynamic
Cmd.perf_track_dynamic) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
Cmd.lookup_performance BlockId
perf_block_id
    where
    lookup :: Map (BlockId, TrackId) b -> Maybe b
lookup Map (BlockId, TrackId) b
track_dyns = case Maybe TrackId
maybe_track_id of
        Maybe TrackId
Nothing -> do
            ((BlockId, TrackId)
_, b
dyn) <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
==BlockId
block_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                (forall k a. Map k a -> [(k, a)]
Map.toAscList Map (BlockId, TrackId) b
track_dyns)
            forall (m :: * -> *) a. Monad m => a -> m a
return b
dyn
        Just TrackId
track_id -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (BlockId
block_id, TrackId
track_id) Map (BlockId, TrackId) b
track_dyns

-- * muted instruments

muted_im_instruments :: Cmd.M m => BlockId -> m (Set ScoreT.Instrument)
muted_im_instruments :: forall (m :: * -> *). M m => BlockId -> m (Set Instrument)
muted_im_instruments BlockId
block_id = do
    Allocations
allocs <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets forall a b. (a -> b) -> a -> b
$ Config -> Allocations
UiConfig.config_allocations forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Ui.state_config
    -- Only im does per-instrument muting, so don't bother if I don't have any
    -- of those.
    Set Instrument
muted <- if Allocations -> Bool
UiConfig.has_im Allocations
allocs
        then forall (m :: * -> *). M m => BlockId -> m (Set Instrument)
get_muted_instrument_tracks BlockId
block_id
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Allocations -> Set Instrument
PlayUtil.muted_instruments Allocations
allocs forall a. Semigroup a => a -> a -> a
<> Set Instrument
muted

get_muted_instrument_tracks :: Cmd.M m => BlockId -> m (Set ScoreT.Instrument)
get_muted_instrument_tracks :: forall (m :: * -> *). M m => BlockId -> m (Set Instrument)
get_muted_instrument_tracks BlockId
block_id = do
    [TrackId]
muted <- forall a. Set a -> [a]
Set.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m (Set TrackId)
PlayUtil.get_muted_tracks
    Map TrackId (Set Instrument)
track_instruments <- Performance -> Map TrackId (Set Instrument)
Cmd.perf_track_instruments forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Performance
get_current BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map TrackId (Set Instrument)
track_instruments)) [TrackId]
muted

-- | This is like 'Cmd.perf_track_instruments', except it uses the track titles
-- instead of the performance.  This means it's less accurate, but can work
-- even before there's a performance and might be faster.
infer_instrument :: Cmd.M m => TrackId -> m (Maybe ScoreT.Instrument)
infer_instrument :: forall (m :: * -> *). M m => TrackId -> m (Maybe Instrument)
infer_instrument TrackId
track_id =
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
Ui.blocks_with_track_id TrackId
track_id) forall a b. (a -> b) -> a -> b
$
        \BlockId
block_id -> forall (m :: * -> *). M m => Track -> m (Maybe Instrument)
lookup_instrument (BlockId
block_id, forall a. a -> Maybe a
Just TrackId
track_id)

-- * default

-- | Get global defaults.
lookup_default_environ :: (Typecheck.Typecheck a, Cmd.M m) =>
    Env.Key -> m (Maybe a)
lookup_default_environ :: forall a (m :: * -> *). (Typecheck a, M m) => Text -> m (Maybe a)
lookup_default_environ Text
name = do
    -- Eval.eval_transform_expr only applies to things in Derived, so I have to
    -- do this gross hack where I stash the result in a Score.Event.
    -- Ultimately it's because I use the return type to infer the lookup
    -- function, and I want to use Score.Event transformers.  It might be
    -- a better design to figure out the lookup function separately, but
    -- meanwhile this hack should be safe.
    Either Text (Stream Event)
result <- forall (m :: * -> *) a. M m => Deriver a -> m (Either Text a)
derive NoteDeriver
smuggle_environ
    Environ
environ <- case Either Text (Stream Event)
result of
        Left Text
err -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
caller forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
        Right Stream Event
val -> case forall a. Stream a -> [a]
Stream.events_of Stream Event
val of
            [] -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
caller forall a. Semigroup a => a -> a -> a
<> Text
" didn't get the fake event it wanted"
            Event
event : [Event]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Event -> Environ
Score.event_environ Event
event
    forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Typecheck a => Text -> Environ -> Either Text (Maybe a)
Env.checked_val Text
name Environ
environ
    where
    caller :: Text
caller = Text
"Perf.lookup_default_environ"

get_default_environ :: (Typecheck.Typecheck a, Cmd.M m) => Env.Key -> m a
get_default_environ :: forall a (m :: * -> *). (Typecheck a, M m) => Text -> m a
get_default_environ Text
name =
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"no default val for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
name)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *). (Typecheck a, M m) => Text -> m (Maybe a)
lookup_default_environ Text
name

-- | The default scale established by 'Ui.config_global_transform', or
-- 'Config.default_scale_id' if there is none.
default_scale_id :: Cmd.M m => m Pitch.ScaleId
default_scale_id :: forall (m :: * -> *). M m => m ScaleId
default_scale_id =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> ScaleId
Pitch.ScaleId Text
Config.default_scale_id) Str -> ScaleId
Expr.str_to_scale_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a (m :: * -> *). (Typecheck a, M m) => Text -> m (Maybe a)
lookup_default_environ Text
EnvKey.scale


-- * play

-- | Given a block, track, and time, find the realtime at that position.  If
-- the track is Nothing, use the first track that has tempo information.  This
-- is necessary because if a track is muted it will have no tempo, but it's
-- confusing if playing from a muted track fails.
get_realtime :: Cmd.M m => Cmd.Performance -> BlockId -> Maybe TrackId
    -> ScoreTime -> m RealTime
get_realtime :: forall (m :: * -> *).
M m =>
Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
get_realtime Performance
perf BlockId
block_id Maybe TrackId
maybe_track_id TrackTime
pos =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showt BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Maybe TrackId
maybe_track_id
            forall a. Semigroup a => a -> a -> a
<> Text
" has no tempo information, so it probably failed to derive.")
        forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
Performance
-> BlockId -> Maybe TrackId -> TrackTime -> m (Maybe RealTime)
lookup_realtime Performance
perf BlockId
block_id Maybe TrackId
maybe_track_id TrackTime
pos

lookup_realtime :: Cmd.M m => Cmd.Performance -> BlockId -> Maybe TrackId
    -> ScoreTime -> m (Maybe RealTime)
lookup_realtime :: forall (m :: * -> *).
M m =>
Performance
-> BlockId -> Maybe TrackId -> TrackTime -> m (Maybe RealTime)
lookup_realtime Performance
perf BlockId
block_id Maybe TrackId
maybe_track_id TrackTime
pos = do
    [TrackId]
track_ids <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). M m => BlockId -> m [TrackId]
Ui.track_ids_of BlockId
block_id) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]))
        Maybe TrackId
maybe_track_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map TrackId -> Maybe RealTime
tempo [TrackId]
track_ids)
    where tempo :: TrackId -> Maybe RealTime
tempo TrackId
tid = forall a. [a] -> Maybe a
Lists.head forall a b. (a -> b) -> a -> b
$ Performance -> TempoFunction
Cmd.perf_tempo Performance
perf BlockId
block_id TrackId
tid TrackTime
pos

-- | Like 'get_realtime', but do multiple at once.
get_realtimes :: Cmd.Performance -> BlockId -> TrackId -> [ScoreTime]
    -> [(ScoreTime, RealTime)]
get_realtimes :: Performance
-> BlockId -> TrackId -> [TrackTime] -> [(TrackTime, RealTime)]
get_realtimes Performance
perf BlockId
block_id TrackId
track_id [TrackTime]
ps =
    [(TrackTime
p, RealTime
t) | (TrackTime
p, RealTime
t : [RealTime]
_)
        <- forall a b. [a] -> [b] -> [(a, b)]
zip [TrackTime]
ps (forall a b. (a -> b) -> [a] -> [b]
map (Performance -> TempoFunction
Cmd.perf_tempo Performance
perf BlockId
block_id TrackId
track_id) [TrackTime]
ps)]

get_inverse_tempo :: Cmd.M m => BlockId -> m Transport.InverseTempoFunction
get_inverse_tempo :: forall (m :: * -> *). M m => BlockId -> m InverseTempoFunction
get_inverse_tempo BlockId
block_id =
    [TrackWarp] -> InverseTempoFunction
TrackWarp.inverse_tempo_func forall b c a. (b -> c) -> (a -> b) -> a -> c
. Performance -> [TrackWarp]
Cmd.perf_warps forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Performance
get BlockId
block_id

-- | Take a RealTime to all the ScoreTimes it corresponds to, if any.
find_play_pos :: Ui.M m => Transport.InverseTempoFunction
    -> RealTime -> m [(ViewId, [(TrackNum, ScoreTime)])]
find_play_pos :: forall (m :: * -> *).
M m =>
InverseTempoFunction
-> RealTime -> m [(ViewId, [(TrackNum, TrackTime)])]
find_play_pos InverseTempoFunction
inv_tempo = forall (m :: * -> *).
M m =>
[(BlockId, [(TrackId, TrackTime)])]
-> m [(ViewId, [(TrackNum, TrackTime)])]
block_pos_to_play_pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. InverseTempoFunction
inv_tempo Stop
Transport.StopAtEnd

-- | Do all the annoying shuffling around to convert the deriver-oriented
-- blocks and tracks to the view-oriented views and tracknums.
--
-- This function has to be careful to not throw on non-existent IDs, because
-- it's called from the monitor_loop.
block_pos_to_play_pos :: Ui.M m => [(BlockId, [(TrackId, ScoreTime)])]
    -> m [(ViewId, [(TrackNum, ScoreTime)])]
block_pos_to_play_pos :: forall (m :: * -> *).
M m =>
[(BlockId, [(TrackId, TrackTime)])]
-> m [(ViewId, [(TrackNum, TrackTime)])]
block_pos_to_play_pos = forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM forall (m :: * -> *).
M m =>
(BlockId, [(TrackId, TrackTime)])
-> m [(ViewId, [(TrackNum, TrackTime)])]
convert

convert :: Ui.M m => (BlockId, [(TrackId, ScoreTime)])
    -> m [(ViewId, [(TrackNum, ScoreTime)])]
convert :: forall (m :: * -> *).
M m =>
(BlockId, [(TrackId, TrackTime)])
-> m [(ViewId, [(TrackNum, TrackTime)])]
convert (BlockId
block_id, [(TrackId, TrackTime)]
track_pos) = do
    [ViewId]
view_ids <- forall k a. Map k a -> [k]
Map.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
Ui.views_of BlockId
block_id
    forall (m :: * -> *). M m => BlockId -> m (Maybe Block)
Ui.lookup_block BlockId
block_id forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Block
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just Block
block -> forall (m :: * -> *) a. Monad m => a -> m a
return [(ViewId
view_id, [(TrackNum, TrackTime)]
tracknum_pos) | ViewId
view_id <- [ViewId]
view_ids]
            where tracknum_pos :: [(TrackNum, TrackTime)]
tracknum_pos = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Block -> (TrackId, TrackTime) -> [(TrackNum, TrackTime)]
tracknums_of Block
block) [(TrackId, TrackTime)]
track_pos

tracknums_of :: Block.Block -> (TrackId, ScoreTime) -> [(TrackNum, ScoreTime)]
tracknums_of :: Block -> (TrackId, TrackTime) -> [(TrackNum, TrackTime)]
tracknums_of Block
block (TrackId
track_id, TrackTime
pos) =
    [ (TrackNum
tracknum, TrackTime
pos)
    | (TrackNum
tracknum, Block.TId TrackId
tid RulerId
_)
        <- forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
0..] (Block -> [TracklikeId]
Block.block_tracklike_ids Block
block)
    , TrackId
tid forall a. Eq a => a -> a -> Bool
== TrackId
track_id
    ]

-- ** find score times

-- | Give a block and score time, return the play position on sub-blocks.
-- The block itself is filtered out of the result.
sub_pos :: Cmd.M m => BlockId -> TrackId -> ScoreTime
    -> m [(BlockId, [(TrackId, ScoreTime)])]
sub_pos :: forall (m :: * -> *).
M m =>
BlockId
-> TrackId -> TrackTime -> m [(BlockId, [(TrackId, TrackTime)])]
sub_pos BlockId
block_id TrackId
track_id TrackTime
pos = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe []) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
Cmd.lookup_performance BlockId
block_id) forall a b. (a -> b) -> a -> b
$ \Performance
perf ->
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *).
M m =>
Performance
-> BlockId -> Maybe TrackId -> TrackTime -> m (Maybe RealTime)
lookup_realtime Performance
perf BlockId
block_id (forall a. a -> Maybe a
Just TrackId
track_id) TrackTime
pos) forall a b. (a -> b) -> a -> b
$ \RealTime
real ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=BlockId
block_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
        Performance -> InverseTempoFunction
Cmd.perf_inv_tempo Performance
perf Stop
Transport.StopAtEnd RealTime
real
    -- lookup_realtime gives Nothing if there's no tempo available which is
    -- likely for a newly added track.  Return [] in that case.