-- 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 manages the performance of music, specifically the creation
    of performance threads.

    Performance is relative to a toplevel block, so each block has its own set
    of caches.  Since performance is lazy, a separate thread will force it
    asynchronously.
-}
module Cmd.Performance (
    SendStatus, update_performance, derive_blocks, performance, derive
    , Process, evaluate_im
    , wait_for_subprocesses
) where
import qualified Control.Concurrent.Chan as Chan
import qualified Control.Monad.State.Strict as Monad.State
import qualified Data.HashSet as HashSet
import qualified Data.List as List
import qualified Data.Map.Lazy as Map.Lazy
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 Data.Text.IO as Text.IO
import qualified Data.Vector as Vector

import qualified Streaming.Prelude as S
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import           System.FilePath ((</>))
import qualified System.IO as IO

import qualified Util.Control as Control
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Processes as Processes
import qualified Util.Thread as Thread
import qualified Util.Vector

import qualified App.Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Msg as Msg
import qualified Cmd.PlayUtil as PlayUtil

import qualified Derive.Derive as Derive
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream

import qualified Instrument.Inst as Inst
import qualified Perform.Im.Convert as Im.Convert
import qualified Perform.RealTime as RealTime
import qualified Perform.Transport as Transport

import qualified Synth.ImGc as ImGc
import qualified Synth.Shared.Config as Config
import qualified Ui.Block as Block
import qualified Ui.ScoreTime as ScoreTime
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


type SendStatus = BlockId -> Msg.DeriveStatus -> IO ()
type StateM = Monad.State.StateT Cmd.State IO ()

{- | Update the performances by rederiving if necessary.  This means figuring
    out ScoreDamage, and if there has been damage, killing any in-progress
    derivation and starting derivation.  This updates performances for the root
    block and all visible blocks.

    The majority of the calls here will bring neither score damage nor
    a changed view id, and thus this will do nothing.

    This is tricky, and I've gotten it wrong in the past, so here's a detailed
    description:

    Merge ui damage with each perf's damage.  Then for each perf, if it's
    'Cmd.state_current_performance' has damage, kill its thread, and remove its
    entry in 'Cmd.state_performance_threads'.  The lack of a thread entry,
    whether because was removed or never existed, means that a block should be
    rederived.  Derivation creates a new 'Cmd.Performance' and an evaluate
    thread, and puts them into 'Cmd.state_current_performance' and
    'Cmd.state_performance_threads' respectively, but due to laziness, no actual
    derivation happens unless someone (like play) happens to look at the
    performance.  This all happens synchronously, so the next time
    'update_performance' is called, it sees a nice clean new Performance with
    no damage.

    Meanwhile, the evaluate thread asynchronously waits for a bit, then
    forces the contents of the Performance, and then sends it back to the
    responder so it can stash it in 'Cmd.state_performance'.  If a new change
    comes in while it's waiting it'll get killed off, and the out-of-date
    derivation will never happen.  Yay for laziness!
-}
update_performance :: SendStatus -> Ui.State -> Cmd.State
    -> Derive.ScoreDamage -> IO Cmd.State
update_performance :: SendStatus -> State -> State -> ScoreDamage -> IO State
update_performance SendStatus
send_status State
ui_state State
cmd_state ScoreDamage
damage =
    -- The update will be modifying Cmd.State, especially PlayState.
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
Monad.State.execStateT (SendStatus -> State -> StateM
run_update SendStatus
send_status State
ui_state)
        (ScoreDamage -> State -> State
insert_damage ScoreDamage
damage State
cmd_state)

run_update :: SendStatus -> Ui.State -> StateM
run_update :: SendStatus -> State -> StateM
run_update SendStatus
send_status State
ui_state = do
    StateM
kill_threads
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SendStatus -> State -> BlockId -> StateM
try_generate_performance SendStatus
send_status State
ui_state)
        (State -> Set BlockId
derive_blocks State
ui_state)

-- | Which blocks should get derived?
derive_blocks :: Ui.State -> Set BlockId
derive_blocks :: State -> Set BlockId
derive_blocks State
ui_state = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe BlockId
root_id [BlockId]
visible
    where
    root_id :: Maybe BlockId
root_id = Config -> Maybe BlockId
UiConfig.config_root (State -> Config
Ui.state_config State
ui_state)
    visible :: [BlockId]
visible = forall a b. (a -> b) -> [a] -> [b]
map View -> BlockId
Block.view_block forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ State -> Map ViewId View
Ui.state_views State
ui_state

try_generate_performance :: SendStatus -> Ui.State -> BlockId -> StateM
try_generate_performance :: SendStatus -> State -> BlockId -> StateM
try_generate_performance SendStatus
send_status State
ui_state BlockId
block_id = do
    State
state <- forall s (m :: * -> *). MonadState s m => m s
Monad.State.get
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State -> BlockId -> Bool
needs_generate State
state BlockId
block_id) forall a b. (a -> b) -> a -> b
$
        State -> Seconds -> SendStatus -> BlockId -> StateM
generate_performance State
ui_state (State -> BlockId -> Seconds
derive_wait State
state BlockId
block_id)
            SendStatus
send_status BlockId
block_id

-- | Theoretically I should be able to do away with the wait, but in practice
-- deriving constantly causes UI latency.
derive_wait :: Cmd.State -> BlockId -> Thread.Seconds
derive_wait :: State -> BlockId -> Seconds
derive_wait State
cmd_state BlockId
block_id
    | BlockId
block_id forall a. Ord a => a -> Set a -> Bool
`Set.member` State -> Set BlockId
Cmd.state_derive_immediately State
cmd_state = Seconds
0
    | Bool
otherwise = Seconds
App.Config.default_derive_wait

-- | Since caches are stored per-performance, score damage is also
-- per-performance.  It accumulates in an existing performance and is cleared
-- when a new performance is created from the old one.
insert_damage :: Derive.ScoreDamage -> Cmd.State -> Cmd.State
insert_damage :: ScoreDamage -> State -> State
insert_damage ScoreDamage
damage
    | ScoreDamage
damage forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = forall a. a -> a
id
    | Bool
otherwise = (PlayState -> PlayState) -> State -> State
modify_play_state forall a b. (a -> b) -> a -> b
$ \PlayState
st -> PlayState
st
        -- Damage update is tricky.  Damage in 'Cmd.state_current_performance'
        -- is a signal that the performance for that block is out of date and
        -- needs to be updated.  Technically all I need is a Bool since it just
        -- checks (damage /= mempty).  But this signal has to go in the current
        -- performance, since it's updated (and hence the damage is cleared)
        -- synchronously, and otherwise I'd get stuck in a loop killing and
        -- starting new derivations.
        --
        -- However, the derivation is relative to 'Cmd.state_performance', so
        -- the damage is also relative to it.  So this damage is actually used
        -- for derivation, not as a out-of-date flag.  When
        -- state_current_performance is promoted to state_performance, the
        -- damage is also cleared.
        { state_current_performance :: Map BlockId Performance
Cmd.state_current_performance =
            Performance -> Performance
update forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlayState -> Map BlockId Performance
Cmd.state_current_performance PlayState
st
        , state_performance :: Map BlockId Performance
Cmd.state_performance = Performance -> Performance
update forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlayState -> Map BlockId Performance
Cmd.state_performance PlayState
st
        }
    where
    update :: Performance -> Performance
update Performance
perf
        | Performance -> Bool
dependency_damaged Performance
perf =
            let !accum :: ScoreDamage
accum = ScoreDamage
damage forall a. Semigroup a => a -> a -> a
<> Performance -> ScoreDamage
Cmd.perf_damage Performance
perf
            in Performance
perf { perf_damage :: ScoreDamage
Cmd.perf_damage = ScoreDamage
accum }
        | Bool
otherwise = Performance
perf
    dependency_damaged :: Performance -> Bool
dependency_damaged Performance
perf = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set BlockId
damaged_blocks Set BlockId
deps
        where Derive.BlockDeps Set BlockId
deps = Performance -> BlockDeps
Cmd.perf_block_deps Performance
perf
    damaged_blocks :: Set BlockId
damaged_blocks =
        ScoreDamage -> Set BlockId
Derive.sdamage_track_blocks ScoreDamage
damage forall a. Semigroup a => a -> a -> a
<> ScoreDamage -> Set BlockId
Derive.sdamage_blocks ScoreDamage
damage

-- | Kill all performance threads with damage.  If they are still deriving
-- they're now out of date and should stop.  Whether or not they finished
-- deriving, this will remove them from 'Cmd.state_performance_threads',
-- which will cause them to rederive.
kill_threads :: StateM
kill_threads :: StateM
kill_threads = do
    PlayState
play_state <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
Monad.State.gets State -> PlayState
Cmd.state_play
    let threads :: Map BlockId Thread
threads = PlayState -> Map BlockId Thread
Cmd.state_performance_threads PlayState
play_state
        perfs :: Map BlockId Performance
perfs = PlayState -> Map BlockId Performance
Cmd.state_current_performance PlayState
play_state
        with_damage :: [BlockId]
with_damage =
            [ BlockId
block_id | (BlockId
block_id, Performance
perf) <- forall k a. Map k a -> [(k, a)]
Map.toList Map BlockId Performance
perfs
            , Performance -> ScoreDamage
Cmd.perf_damage Performance
perf forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty
            ]
        -- Kill threads for damaged blocks, but also ones with no performance
        -- at all.  This is so Cmd.invalidate_performances can force a
        -- re-generate by clearing out state_current_performance, and doesn't
        -- need to be in IO to immediately kill the threads.
        obsolete :: BlockId -> Bool
obsolete BlockId
bid = forall k a. Ord k => k -> Map k a -> Bool
Map.notMember BlockId
bid Map BlockId Performance
perfs Bool -> Bool -> Bool
|| BlockId
bid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BlockId]
with_damage
        kill :: [(BlockId, Thread)]
kill = forall a. (a -> Bool) -> [a] -> [a]
filter (BlockId -> Bool
obsolete forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map BlockId Thread
threads
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Thread -> IO ()
Cmd.kill_thread forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(BlockId, Thread)]
kill
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
Monad.State.modify forall a b. (a -> b) -> a -> b
$ (PlayState -> PlayState) -> State -> State
modify_play_state forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ PlayState
play_state
        { state_performance_threads :: Map BlockId Thread
Cmd.state_performance_threads = forall k a. Ord k => [k] -> Map k a -> Map k a
Maps.deleteKeys (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(BlockId, Thread)]
kill)
            (PlayState -> Map BlockId Thread
Cmd.state_performance_threads PlayState
play_state)
        }


-- * performance evaluation

-- | True if this BlockId should be regenerated.  This happens if there is
-- no performance, which means either there never was one, or it was deleted
-- by 'kill_threads' thanks to ScoreDamage.
--
-- I use 'Cmd.state_performance_threads' and not
-- 'Cmd.state_current_performance', because the thread is filled in
-- synchronously, while the current performance is filled in later.
needs_generate :: Cmd.State -> BlockId -> Bool
needs_generate :: State -> BlockId -> Bool
needs_generate State
state BlockId
block_id = Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
Map.member BlockId
block_id Map BlockId Thread
perfs)
    where perfs :: Map BlockId Thread
perfs = PlayState -> Map BlockId Thread
Cmd.state_performance_threads forall a b. (a -> b) -> a -> b
$ State -> PlayState
Cmd.state_play State
state

-- | Start a new performance thread.
--
-- Pull previous caches from the existing performance, if any.  Use them to
-- generate a new performance, kick off a thread for it, and insert the new
-- thread into 'Cmd.state_performance_threads' and performance into
-- 'Cmd.state_current_performance'.  It will be promoted to
-- 'Cmd.state_performance' when 'evaluate_performance' completes.
generate_performance :: Ui.State -> Thread.Seconds -> SendStatus -> BlockId
    -> StateM
generate_performance :: State -> Seconds -> SendStatus -> BlockId -> StateM
generate_performance State
ui_state Seconds
wait SendStatus
send_status BlockId
block_id = do
    State
cmd_state <- forall s (m :: * -> *). MonadState s m => m s
Monad.State.get
    let (Performance
perf, [Msg]
logs) = State -> State -> BlockId -> (Performance, [Msg])
derive State
ui_state State
cmd_state BlockId
block_id
    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
    Async ()
thread_id <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> IO a -> IO (Async a)
Thread.asyncLogged ([Char]
"perf:" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettys BlockId
block_id) forall a b. (a -> b) -> a -> b
$ do
        let allocs :: Allocations
allocs = Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Allocations
UiConfig.allocations forall f a. Lens f a -> f -> a
#$ State
ui_state
            im_config :: Config
im_config = Config -> Config
Cmd.config_im (State -> Config
Cmd.state_config State
cmd_state)
        let lookup_inst :: Instrument -> Maybe ResolvedInstrument
lookup_inst = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State -> Instrument -> Either SynthName ResolvedInstrument
Cmd.state_lookup_instrument State
ui_state State
cmd_state
        Maybe Config
-> (Instrument -> Maybe ResolvedInstrument)
-> Seconds
-> SendStatus
-> [Char]
-> RealTime
-> BlockId
-> Performance
-> IO ()
evaluate_performance
            (if Allocations -> Bool
im_allocated Allocations
allocs then forall a. a -> Maybe a
Just Config
im_config else forall a. Maybe a
Nothing)
            Instrument -> Maybe ResolvedInstrument
lookup_inst Seconds
wait SendStatus
send_status (State -> [Char]
Cmd.score_path State
cmd_state)
            (PlayState -> RealTime
Cmd.state_play_multiplier (State -> PlayState
Cmd.state_play State
cmd_state)) BlockId
block_id Performance
perf
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
Monad.State.modify forall a b. (a -> b) -> a -> b
$ (PlayState -> PlayState) -> State -> State
modify_play_state forall a b. (a -> b) -> a -> b
$ \PlayState
st -> PlayState
st
        { state_performance_threads :: Map BlockId Thread
Cmd.state_performance_threads = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BlockId
block_id
            (Async () -> Thread
Cmd.Thread Async ()
thread_id) (PlayState -> Map BlockId Thread
Cmd.state_performance_threads PlayState
st)
        , state_current_performance :: Map BlockId Performance
Cmd.state_current_performance = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BlockId
block_id
            Performance
perf (PlayState -> Map BlockId Performance
Cmd.state_current_performance PlayState
st)
        }
    -- If the derivation somehow failed, then the old performance will remain,
    -- and since there is no thread, this will try again the next time around.

{-# SCC derive #-}
derive :: Ui.State -> Cmd.State -> BlockId -> (Cmd.Performance, [Log.Msg])
derive :: State -> State -> BlockId -> (Performance, [Msg])
derive State
ui_state State
cmd_state BlockId
block_id = (Performance
perf, [Msg]
logs)
    where
    perf :: Performance
perf = case Either Error (Maybe Result, State, UiDamage)
cmd_result of
        Left Error
err -> SynthName -> Performance
broken_performance forall a b. (a -> b) -> a -> b
$
            SynthName
"derivation for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt BlockId
block_id forall a. Semigroup a => a -> a -> a
<> SynthName
" failed: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty Error
err
        Right (Maybe Result
derive_result, State
_, UiDamage
_) -> case Maybe Result
derive_result of
            Maybe Result
Nothing -> SynthName -> Performance
broken_performance forall a b. (a -> b) -> a -> b
$
                SynthName
"derivation for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt BlockId
block_id forall a. Semigroup a => a -> a -> a
<> SynthName
" aborted"
            Just Result
result -> State -> Result -> Performance
performance State
ui_state Result
result
    -- The previous cache comes from the fully evaluated performance, since
    -- otherwise there's no point killing the 'evaluate_performance' thread if
    -- the cache makes all derivation serialized.
    prev_cache :: Cache
prev_cache = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Performance -> Cache
Cmd.perf_derive_cache forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id forall a b. (a -> b) -> a -> b
$
        PlayState -> Map BlockId Performance
Cmd.state_performance forall a b. (a -> b) -> a -> b
$ State -> PlayState
Cmd.state_play State
cmd_state
    -- The damage also comes from the current performance, since that's where
    -- the performance is deriving from.
    damage :: ScoreDamage
damage = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Performance -> ScoreDamage
Cmd.perf_damage forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id forall a b. (a -> b) -> a -> b
$
        PlayState -> Map BlockId Performance
Cmd.state_performance forall a b. (a -> b) -> a -> b
$ State -> PlayState
Cmd.state_play State
cmd_state
    (State
_state, [Thru]
_midi, [Msg]
logs, Either Error (Maybe Result, State, UiDamage)
cmd_result) = forall a. State -> State -> CmdT Identity a -> Result (Maybe a)
Cmd.run_id State
ui_state State
cmd_state forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *).
M m =>
Cache -> ScoreDamage -> BlockId -> m Result
PlayUtil.derive_block Cache
prev_cache ScoreDamage
damage BlockId
block_id

evaluate_performance :: Maybe Config.Config
    -> (ScoreT.Instrument -> Maybe Cmd.ResolvedInstrument)
    -> Thread.Seconds -> SendStatus -> FilePath -> RealTime -> BlockId
    -> Cmd.Performance -> IO ()
evaluate_performance :: Maybe Config
-> (Instrument -> Maybe ResolvedInstrument)
-> Seconds
-> SendStatus
-> [Char]
-> RealTime
-> BlockId
-> Performance
-> IO ()
evaluate_performance Maybe Config
im_config Instrument -> Maybe ResolvedInstrument
lookup_inst Seconds
wait SendStatus
send_status [Char]
score_path
        RealTime
play_multiplier BlockId
block_id Performance
perf = do
    SendStatus
send_status BlockId
block_id DeriveStatus
Msg.OutOfDate
    Seconds -> IO ()
Thread.delay Seconds
wait
    SendStatus
send_status BlockId
block_id DeriveStatus
Msg.Deriving
    -- I just force the logs here, and wait for a play to actually write them.
    ((), Metric Seconds
metric) <- forall (m :: * -> *) a. MonadIO m => m a -> m (a, Metric Seconds)
Thread.timeAction forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Performance -> ()
Msg.force_performance Performance
perf
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Instrument -> Maybe ResolvedInstrument)
-> Vector Event -> [(Event, SynthName)]
check_dummy Instrument -> Maybe ResolvedInstrument
lookup_inst (Performance -> Vector Event
Msg.perf_events Performance
perf)) forall a b. (a -> b) -> a -> b
$ \(Event
event, SynthName
msg) ->
        forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ SynthName
"note with dummy instrument: " forall a. Semigroup a => a -> a -> a
<> Event -> SynthName
Score.short_event Event
event
            forall a. Semigroup a => a -> a -> a
<> SynthName
": " forall a. Semigroup a => a -> a -> a
<> SynthName
msg
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall time. Metric time -> time
Thread.metricWall Metric Seconds
metric forall a. Ord a => a -> a -> Bool
> Seconds
1) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ SynthName
"derived " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt BlockId
block_id forall a. Semigroup a => a -> a -> a
<> SynthName
" in "
            forall a. Semigroup a => a -> a -> a
<> Metric Seconds -> SynthName
Thread.showMetric Metric Seconds
metric
    -- This should match the adjust0 in 'Cmd.Play.start_adjustment'.
    let adjust0 :: RealTime
adjust0 = case forall a. Vector a -> [a]
Vector.toList (Performance -> Vector Event
Cmd.perf_events Performance
perf) of
            Event
event : [Event]
_ -> forall a. Ord a => a -> a -> a
max (- Event -> RealTime
Score.event_start Event
event) RealTime
0
            [Event]
_ -> RealTime
0
    ([Process]
procs, Vector Event
events) <- case Maybe Config
im_config of
        Maybe Config
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], Performance -> Vector Event
Cmd.perf_events Performance
perf)
        Just Config
config -> Config
-> (Instrument -> Maybe ResolvedInstrument)
-> [Char]
-> RealTime
-> RealTime
-> BlockId
-> Vector Event
-> IO ([Process], Vector Event)
evaluate_im Config
config Instrument -> Maybe ResolvedInstrument
lookup_inst [Char]
score_path
            RealTime
adjust0 RealTime
play_multiplier BlockId
block_id (Performance -> Vector Event
Cmd.perf_events Performance
perf)
    SendStatus
send_status BlockId
block_id forall a b. (a -> b) -> a -> b
$ Performance -> ImStarted -> DeriveStatus
Msg.DeriveComplete
        (Performance
perf { perf_events :: Vector Event
Cmd.perf_events = Vector Event
events })
        (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Process]
procs then ImStarted
Msg.ImUnnecessary else ImStarted
Msg.ImStarted)
    Bool
ok <- case Maybe Config
im_config of
        Just Config
config -> BlockId
-> (Message -> ImStatus)
-> (DeriveStatus -> IO ())
-> Set Process
-> IO Bool
watch_subprocesses BlockId
block_id
            (InverseTempoFunction
-> (TrackId -> Bool)
-> [Char]
-> [Char]
-> RealTime
-> RealTime
-> Message
-> ImStatus
make_status (Performance -> InverseTempoFunction
Cmd.perf_inv_tempo Performance
perf)
                (State -> TrackId -> Bool
state_wants_waveform (Performance -> State
Cmd.perf_ui_state Performance
perf))
                (Config -> [Char]
Config.imDir Config
config) [Char]
score_path RealTime
adjust0 RealTime
play_multiplier)
            (SendStatus
send_status BlockId
block_id)
            (forall a. Ord a => [a] -> Set a
Set.fromList [Process]
procs)
        Maybe Config
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Process]
procs) forall a b. (a -> b) -> a -> b
$ do
        Maybe Stats
stats <- case (Bool
ok, Maybe Config
im_config) of
            (Bool
True, Just Config
config) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> IO Stats
im_gc forall a b. (a -> b) -> a -> b
$
                [Char] -> [Char] -> BlockId -> [Char]
Config.outputDirectory (Config -> [Char]
Config.imDir Config
config) [Char]
score_path BlockId
block_id
            (Bool, Maybe Config)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        SendStatus
send_status BlockId
block_id forall a b. (a -> b) -> a -> b
$ BlockId -> Set TrackId -> ImStatus -> DeriveStatus
Msg.ImStatus BlockId
block_id forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$
            Bool -> Maybe Stats -> ImStatus
Msg.ImComplete (Bool -> Bool
not Bool
ok) Maybe Stats
stats

im_gc :: FilePath -> IO ImGc.Stats
im_gc :: [Char] -> IO Stats
im_gc [Char]
output_dir = do
    Stats
stats <- [Char] -> IO Stats
ImGc.gc [Char]
output_dir
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Stats -> ChunkNum
ImGc._deletedFiles Stats
stats forall a. Ord a => a -> a -> Bool
> ChunkNum
0) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Stats -> SynthName
ImGc.showStats Stats
stats
    forall (m :: * -> *) a. Monad m => a -> m a
return Stats
stats

-- | Return events with a 'Inst.Dummy' backend.  These shouldn't have made it
-- through to actual performance.
check_dummy :: (ScoreT.Instrument -> Maybe Cmd.ResolvedInstrument)
    -> Vector.Vector Score.Event -> [(Score.Event, Text)]
check_dummy :: (Instrument -> Maybe ResolvedInstrument)
-> Vector Event -> [(Event, SynthName)]
check_dummy Instrument -> Maybe ResolvedInstrument
lookup_inst = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (HashSet Instrument, [(Event, SynthName)])
-> Event -> (HashSet Instrument, [(Event, SynthName)])
go (forall a. HashSet a
HashSet.empty, [])
    where
    go :: (HashSet Instrument, [(Event, SynthName)])
-> Event -> (HashSet Instrument, [(Event, SynthName)])
go (HashSet Instrument
seen, [(Event, SynthName)]
warns) Event
event
        | forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member Instrument
inst HashSet Instrument
seen = (HashSet Instrument
seen, [(Event, SynthName)]
warns)
        | Bool
otherwise =
            ( forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Instrument
inst HashSet Instrument
seen
            , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(Event, SynthName)]
warns (\SynthName
msg -> (Event
event, SynthName
msg) forall a. a -> [a] -> [a]
: [(Event, SynthName)]
warns) (Instrument -> Maybe SynthName
is_dummy Instrument
inst)
            -- , if is_dummy inst then event : warns else warns
            )
        where
        inst :: Instrument
inst = Event -> Instrument
Score.event_instrument Event
event
    is_dummy :: Instrument -> Maybe SynthName
is_dummy Instrument
inst = case ResolvedInstrument -> Backend
Cmd.inst_backend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instrument -> Maybe ResolvedInstrument
lookup_inst Instrument
inst of
        Just (Cmd.Dummy SynthName
msg) -> forall a. a -> Maybe a
Just SynthName
msg
        Maybe Backend
_ -> forall a. Maybe a
Nothing

state_wants_waveform :: Ui.State -> TrackId -> Bool
state_wants_waveform :: State -> TrackId -> Bool
state_wants_waveform State
state TrackId
track_id = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Track -> Bool
Track.track_waveform forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
track_id (State -> Map TrackId Track
Ui.state_tracks State
state)

type Process = (FilePath, [String])

-- | Watch subprocesses and convert their msgs to Msg.DeriveStatus.
watch_subprocesses :: BlockId -> (Config.Message -> ImStatus)
    -> (Msg.DeriveStatus -> IO ()) -> Set Process -> IO Bool
watch_subprocesses :: BlockId
-> (Message -> ImStatus)
-> (DeriveStatus -> IO ())
-> Set Process
-> IO Bool
watch_subprocesses BlockId
root_block_id Message -> ImStatus
make_status DeriveStatus -> IO ()
send_status Set Process
procs =
    forall a.
Set Process
-> (Stream (Of (Process, Progress)) IO Bool -> IO a) -> IO a
stream_subprocesses Set Process
procs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a x r.
Monad m =>
(a -> m x) -> Stream (Of a) m r -> m r
S.mapM_ (Process, Progress) -> IO ()
watch
    where
    watch :: (Process, Progress) -> IO ()
watch (([Char]
cmd, [[Char]]
args), ProcessExit Exit
code)
        | Exit
code forall a. Eq a => a -> a -> Bool
/= ChunkNum -> Exit
Processes.ExitCode ChunkNum
0 = forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ SynthName
"subprocess failed with "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt Exit
code forall a. Semigroup a => a -> a -> a
<> SynthName
": " forall a. Semigroup a => a -> a -> a
<> [SynthName] -> SynthName
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> SynthName
txt ([Char]
cmd forall a. a -> [a] -> [a]
: [[Char]]
args))
        | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    watch (Process
_, Message Message
msg)
        -- This is an update for a child block.  I only display progress
        -- for each block as its own toplevel.  If a block is child of
        -- another, I can see its prorgess in the parent.
        | Message -> BlockId
Config._blockId Message
msg forall a. Eq a => a -> a -> Bool
/= BlockId
root_block_id = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise = case Message -> ImStatus
make_status Message
msg of
            ImStatus DeriveStatus
status -> DeriveStatus -> IO ()
send_status forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DeriveStatus -> IO DeriveStatus
resolve_waveform_links DeriveStatus
status
            ImWarn Msg
msg -> forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write Msg
msg
            ImFail Msg
msg -> forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write Msg
msg
            ImStatus
ImNothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Like 'watch_subprocesses', but notify the callback as soon as
-- they have all rendered enough audio.
wait_for_subprocesses :: IO () -> Set ScoreT.Instrument -> Set Process
    -> IO Bool
wait_for_subprocesses :: IO () -> Set Instrument -> Set Process -> IO Bool
wait_for_subprocesses IO ()
ready Set Instrument
expected_instruments Set Process
procs =
    forall a.
Set Process
-> (Stream (Of (Process, Progress)) IO Bool -> IO a) -> IO a
stream_subprocesses Set Process
procs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) st a r.
Monad m =>
(st -> a -> m st) -> st -> Stream (Of a) m r -> m r
s_mapAccumL_ (Set Process, Set Instrument)
-> (Process, Progress) -> IO (Set Process, Set Instrument)
check (forall a. Set a
Set.empty, forall a. Set a
Set.empty)
    where
    check :: (Set Process, Set Instrument)
-> (Process, Progress) -> IO (Set Process, Set Instrument)
check (Set Process
started, Set Instrument
insts) (([Char]
cmd, [[Char]]
args), ProcessExit Exit
code) = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Exit
code forall a. Eq a => a -> a -> Bool
== ChunkNum -> Exit
Processes.ExitCode ChunkNum
0) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ SynthName
"subprocess failed with "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt Exit
code forall a. Semigroup a => a -> a -> a
<> SynthName
": " forall a. Semigroup a => a -> a -> a
<> [SynthName] -> SynthName
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> SynthName
txt ([Char]
cmd forall a. a -> [a] -> [a]
: [[Char]]
args))
        forall (m :: * -> *) a. Monad m => a -> m a
return (Set Process
started, Set Instrument
insts)
    check (Set Process
started, Set Instrument
insts) (Process
proc, Message Message
msg) = case Message -> Payload
Config._payload Message
msg of
        Config.WaveformsCompleted [ChunkNum]
chunks
            | ChunkNum
0 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ChunkNum]
chunks -> do
                -- TODO compute chunk for a specific time, not always 0
                let started2 :: Set Process
started2 = forall a. Ord a => a -> Set a -> Set a
Set.insert Process
proc Set Process
started
                    insts2 :: Set Instrument
insts2 = forall a. Ord a => a -> Set a -> Set a
Set.insert (Message -> Instrument
Config._instrument Message
msg) Set Instrument
insts
                forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ SynthName
"started: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty Set Process
started2
                    forall a. Semigroup a => a -> a -> a
<> SynthName
", insts: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty Set Instrument
insts2
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set Process
started2 forall a. Eq a => a -> a -> Bool
== Set Process
procs Bool -> Bool -> Bool
&& Set Instrument
insts2 forall a. Eq a => a -> a -> Bool
== Set Instrument
expected_instruments) IO ()
ready
                forall (m :: * -> *) a. Monad m => a -> m a
return (Set Process
started2, Set Instrument
insts2)
            | Bool
otherwise -> IO (Set Process, Set Instrument)
ignore
        Config.Failure SynthName
err -> forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.warn SynthName
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Set Process, Set Instrument)
ignore
        Config.Warn Stack
stack SynthName
msg -> forall (m :: * -> *).
(Stack, LogMonad m) =>
Stack -> SynthName -> m ()
Log.warn_stack Stack
stack SynthName
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Set Process, Set Instrument)
ignore
        Config.RenderingRange {} -> IO (Set Process, Set Instrument)
ignore
        where ignore :: IO (Set Process, Set Instrument)
ignore = forall (m :: * -> *) a. Monad m => a -> m a
return (Set Process
started, Set Instrument
insts)

data Progress = ProcessExit Processes.Exit | Message Config.Message

-- | Watch each subprocess, return when they all exit.  The stream returns
-- False if there was some failure along the way.
--
-- This is a bracket and doesn't return the stream because I want to kill the
-- subprocesses when leaving the scope.
stream_subprocesses :: Set Process
    -> (S.Stream (S.Of (Process, Progress)) IO Bool -> IO a) -> IO a
stream_subprocesses :: forall a.
Set Process
-> (Stream (Of (Process, Progress)) IO Bool -> IO a) -> IO a
stream_subprocesses Set Process
procs Stream (Of (Process, Progress)) IO Bool -> IO a
action
    | forall a. Set a -> Bool
Set.null Set Process
procs = Stream (Of (Process, Progress)) IO Bool -> IO a
action forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | Bool
otherwise = forall a. [Process] -> (Chan (Process, TalkOut) -> IO a) -> IO a
Processes.multipleOutput (forall a. Set a -> [a]
Set.toList Set Process
procs) forall a b. (a -> b) -> a -> b
$ \Chan (Process, TalkOut)
chan ->
        Stream (Of (Process, Progress)) IO Bool -> IO a
action forall a b. (a -> b) -> a -> b
$ forall state a. state -> ((state -> a) -> state -> a) -> a
Control.loop1 (Set Process
procs, Bool
True) forall a b. (a -> b) -> a -> b
$ \(Set Process, Bool) -> Stream (Of (Process, Progress)) IO Bool
loop (Set Process
procs, Bool
ok) -> if
            | forall a. Set a -> Bool
Set.null Set Process
procs -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ok
            | Bool
otherwise -> do
                (Process
proc, TalkOut
out) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> IO a
Chan.readChan Chan (Process, TalkOut)
chan
                (Set Process, Bool) -> Stream (Of (Process, Progress)) IO Bool
loop forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {m :: * -> *} {a}.
(MonadIO m, Ord a) =>
Set a
-> Bool
-> a
-> TalkOut
-> Stream (Of (a, Progress)) m (Set a, Bool)
process Set Process
procs Bool
ok Process
proc TalkOut
out
    where
    process :: Set a
-> Bool
-> a
-> TalkOut
-> Stream (Of (a, Progress)) m (Set a, Bool)
process Set a
procs Bool
ok a
proc = \case
        Processes.Stderr SynthName
line -> forall {m :: * -> *}. MonadIO m => SynthName -> m ()
put SynthName
line forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Set a
procs, Bool
ok)
        Processes.Stdout SynthName
line -> do
            Bool
ok1 <- forall {m :: * -> *} {a}.
MonadIO m =>
a -> SynthName -> Stream (Of (a, Progress)) m Bool
progress a
proc SynthName
line
            forall (m :: * -> *) a. Monad m => a -> m a
return (Set a
procs, Bool
ok Bool -> Bool -> Bool
&& Bool
ok1)
        Processes.Exit Exit
code -> do
            forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield (a
proc, Exit -> Progress
ProcessExit Exit
code)
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> Set a -> Set a
Set.delete a
proc Set a
procs, Bool
ok Bool -> Bool -> Bool
&& Exit
code forall a. Eq a => a -> a -> Bool
== ChunkNum -> Exit
Processes.ExitCode ChunkNum
0)
    progress :: a -> SynthName -> Stream (Of (a, Progress)) m Bool
progress a
proc SynthName
line = case SynthName -> Maybe Message
Config.parseMessage SynthName
line of
        Maybe Message
Nothing -> do
            forall {m :: * -> *}. MonadIO m => SynthName -> m ()
put forall a b. (a -> b) -> a -> b
$ SynthName
"couldn't parse: " forall a. Semigroup a => a -> a -> a
<> SynthName
line
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just Message
msg -> do
            forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield (a
proc, Message -> Progress
Message Message
msg)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Message -> Payload
Config._payload Message
msg of
                Config.Failure {} -> Bool
False
                Payload
_ -> Bool
True
    -- These get called concurrently, so avoid jumbled output.
    put :: SynthName -> m ()
put SynthName
line = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
Log.with_stdio_lock forall a b. (a -> b) -> a -> b
$ Handle -> SynthName -> IO ()
Text.IO.hPutStrLn Handle
IO.stdout SynthName
line

data ImStatus =
    ImStatus Msg.DeriveStatus | ImWarn Log.Msg | ImFail Log.Msg | ImNothing
    deriving (ChunkNum -> ImStatus -> ShowS
[ImStatus] -> ShowS
ImStatus -> [Char]
forall a.
(ChunkNum -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ImStatus] -> ShowS
$cshowList :: [ImStatus] -> ShowS
show :: ImStatus -> [Char]
$cshow :: ImStatus -> [Char]
showsPrec :: ChunkNum -> ImStatus -> ShowS
$cshowsPrec :: ChunkNum -> ImStatus -> ShowS
Show)

-- | Convert the status output from an im subprocess to an 'ImStatus'.
make_status :: Transport.InverseTempoFunction -> (TrackId -> Bool) -> FilePath
    -> FilePath -> RealTime -> RealTime -> Config.Message -> ImStatus
make_status :: InverseTempoFunction
-> (TrackId -> Bool)
-> [Char]
-> [Char]
-> RealTime
-> RealTime
-> Message
-> ImStatus
make_status InverseTempoFunction
inv_tempo TrackId -> Bool
wants_waveform [Char]
im_dir [Char]
score_path RealTime
adjust0 RealTime
play_multiplier
        (Config.Message BlockId
block_id Set TrackId
track_ids Instrument
instrument Payload
payload) =
    case Payload
payload of
        Config.RenderingRange RealTime
start RealTime
end ->
            ImStatus -> ImStatus
status forall a b. (a -> b) -> a -> b
$ Instrument -> RealTime -> RealTime -> ImStatus
Msg.ImRenderingRange Instrument
instrument RealTime
start RealTime
end
        Config.WaveformsCompleted [ChunkNum]
chunknums
            | forall a. Set a -> Bool
Set.null Set TrackId
wanted_track_ids -> ImStatus
ImNothing
            | Bool
otherwise -> case forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ChunkNum -> Either SynthName WaveformChunk
make_waveform [ChunkNum]
chunknums of
                Right [WaveformChunk]
waveforms -> ImStatus -> ImStatus
status forall a b. (a -> b) -> a -> b
$ [WaveformChunk] -> ImStatus
Msg.ImWaveformsCompleted [WaveformChunk]
waveforms
                Left SynthName
err -> Msg -> ImStatus
ImWarn forall a b. (a -> b) -> a -> b
$ Stack => Priority -> Maybe Stack -> SynthName -> Msg
Log.msg Priority
Log.Warn forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
                    SynthName
"to_score for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty [ChunkNum]
chunknums forall a. Semigroup a => a -> a -> a
<> SynthName
": " forall a. Semigroup a => a -> a -> a
<> SynthName
err
        Config.Warn Stack
stack SynthName
err -> Msg -> ImStatus
ImWarn forall a b. (a -> b) -> a -> b
$ Stack => Priority -> Maybe Stack -> SynthName -> Msg
Log.msg Priority
Log.Warn (forall a. a -> Maybe a
Just Stack
stack) forall a b. (a -> b) -> a -> b
$
            SynthName
"im instrument " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty Instrument
instrument forall a. Semigroup a => a -> a -> a
<> SynthName
": " forall a. Semigroup a => a -> a -> a
<> SynthName
err
        Config.Failure SynthName
err -> Msg -> ImStatus
ImFail forall a b. (a -> b) -> a -> b
$ Stack => Priority -> Maybe Stack -> SynthName -> Msg
Log.msg Priority
Log.Warn forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
            SynthName
"im failure: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty BlockId
block_id forall a. Semigroup a => a -> a -> a
<> SynthName
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty Set TrackId
track_ids
            forall a. Semigroup a => a -> a -> a
<> SynthName
": " forall a. Semigroup a => a -> a -> a
<> SynthName
err
    where
    status :: ImStatus -> ImStatus
status = DeriveStatus -> ImStatus
ImStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> Set TrackId -> ImStatus -> DeriveStatus
Msg.ImStatus BlockId
block_id Set TrackId
wanted_track_ids

    wanted_track_ids :: Set TrackId
wanted_track_ids = forall a. (a -> Bool) -> Set a -> Set a
Set.filter TrackId -> Bool
wants_waveform Set TrackId
track_ids
    make_waveform :: ChunkNum -> Either SynthName WaveformChunk
make_waveform ChunkNum
chunknum = do
        (TrackTime
start, [Double]
ratios) <- (RealTime -> Either SynthName TrackTime)
-> RealTime
-> RealTime
-> ChunkNum
-> Either SynthName (TrackTime, [Double])
chunk_ratios forall {m :: * -> *}.
MonadError SynthName m =>
RealTime -> m TrackTime
to_score
            (ChunkNum -> RealTime
time_at ChunkNum
chunknum) (ChunkNum -> RealTime
time_at (ChunkNum
chunknumforall a. Num a => a -> a -> a
+ChunkNum
1)) ChunkNum
ratios_per_chunk
        TrackTime
adjust0 <- forall {m :: * -> *}.
MonadError SynthName m =>
RealTime -> m TrackTime
to_score RealTime
adjust0
        -- Debug.tracepM "start, ratio"
        --     ((time_at chunknum, time_at (chunknum+1)), start, ratios)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Track.WaveformChunk
            { _filename :: [Char]
_filename = [Char] -> [Char] -> BlockId -> Instrument -> ChunkNum -> [Char]
Config.chunkPath [Char]
im_dir [Char]
score_path BlockId
block_id
                Instrument
instrument ChunkNum
chunknum
            , _chunknum :: ChunkNum
_chunknum = ChunkNum
chunknum
            , _start :: TrackTime
_start = TrackTime
start forall a. Num a => a -> a -> a
* RealTime -> TrackTime
RealTime.to_score RealTime
play_multiplier forall a. Num a => a -> a -> a
- TrackTime
adjust0
            , _ratios :: [Double]
_ratios = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Fractional a => a -> a -> a
/ RealTime -> Double
RealTime.to_seconds RealTime
play_multiplier) [Double]
ratios
            }
    time_at :: ChunkNum -> RealTime
time_at ChunkNum
chunknum = Double -> RealTime
RealTime.seconds forall a b. (a -> b) -> a -> b
$
        forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ChunkNum
chunknum forall a. Num a => a -> a -> a
* ChunkNum
Config.chunkSeconds
    -- If this fails, it means I don't have any tempo info for this
    -- (block_id, track_id), which likely means the block or track failed
    -- to derive, at which point I shouldn't have gotten any notes from it.
    -- So this shouldn't happen.
    to_score :: RealTime -> m TrackTime
to_score RealTime
t = forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (SynthName
"no ScoreTime for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty RealTime
t) forall a b. (a -> b) -> a -> b
$
        InverseTempoFunction
-> BlockId -> Set TrackId -> RealTime -> Maybe TrackTime
real_to_score InverseTempoFunction
inv_tempo BlockId
block_id Set TrackId
track_ids RealTime
t

-- | How many ratios to put into 'Track._ratios'.  This will make waveform
-- display more accurate when tempos change, since it's the resolution used
-- to warp the waveform to show in ScoreTime.  'chunk_ratios' calculates the
-- actual ratios.  The cost is that it's more expensive to sample more
-- ratios, and ship them to C++, and is a waste in the common case of a
-- constant tempo.
--
-- TODO It would be better to give exact tempo breakpoints, but since I work
-- with Warp rather than a tempo signal, I'd have to get the derivative to
-- get tempo back, and it will have to be sampled anyway if it's changing.
-- Also, it would be more efficient for the whole block or tracks to get
-- a single tempo signal so it can warp waveform accordingly, rather than
-- every chunk getting its own independent ratios.  At the moment, it dosen't
-- seem like a big priority if waveform display is a bit inaccurate, because
-- I'm not using it to line anything up.
ratios_per_chunk :: Int
ratios_per_chunk :: ChunkNum
ratios_per_chunk = ChunkNum
2

chunk_ratios :: (RealTime -> Either Text ScoreTime) -> RealTime -> RealTime
    -> Int -> Either Text (ScoreTime, [Double])
chunk_ratios :: (RealTime -> Either SynthName TrackTime)
-> RealTime
-> RealTime
-> ChunkNum
-> Either SynthName (TrackTime, [Double])
chunk_ratios RealTime -> Either SynthName TrackTime
to_score RealTime
start RealTime
end ChunkNum
n = do
    [TrackTime]
score_bps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RealTime -> Either SynthName TrackTime
to_score [RealTime]
bps
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> a
head [TrackTime]
score_bps, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TrackTime -> TrackTime -> Double
ratio_at [TrackTime]
score_bps (forall a. ChunkNum -> [a] -> [a]
drop ChunkNum
1 [TrackTime]
score_bps))
    where
    ratio_at :: TrackTime -> TrackTime -> Double
ratio_at TrackTime
start TrackTime
end =
        (forall a b. (Integral a, Num b) => a -> b
fromIntegral ChunkNum
Config.chunkSeconds forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral ChunkNum
n)
            forall a. Fractional a => a -> a -> a
/ TrackTime -> Double
ScoreTime.to_double (TrackTime
end forall a. Num a => a -> a -> a
- TrackTime
start)
    bps :: [RealTime]
bps = forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.rangeEnd RealTime
start RealTime
end ((RealTime
end forall a. Num a => a -> a -> a
- RealTime
start) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral ChunkNum
n)

-- | Resolve symlinks in 'Track._filename's.  The PeakCache uses the filename
-- as a key, so I can get false hits if I use the symlinks, which all look like
-- 000.wav.
--
-- I don't do this in 'make_status' because that would put the whole thing into
-- IO.
resolve_waveform_links :: Msg.DeriveStatus -> IO Msg.DeriveStatus
resolve_waveform_links :: DeriveStatus -> IO DeriveStatus
resolve_waveform_links (Msg.ImStatus BlockId
block_id Set TrackId
track_ids
        (Msg.ImWaveformsCompleted [WaveformChunk]
waveforms)) = do

    -- resolved <- mapM (Directory.getSymbolicLinkTarget . Track._filename)
    --     waveforms
    -- when (any (not . ("checkpoint/" `List.isPrefixOf`)) resolved) $ do
    --     Log.error $ "bad symlink in: " <> pretty
    --         (zip (map Track._filename waveforms) resolved)
    --     let dir = FilePath.takeDirectory $ Track._filename (head waveforms)
    --     Process.callProcess "ls" ["-l", dir]

    [[Char]]
fns <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> IO [Char]
resolve_link forall b c a. (b -> c) -> (a -> b) -> a -> c
. WaveformChunk -> [Char]
Track._filename) [WaveformChunk]
waveforms
    -- I got a directory in there once and don't know why...
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
".wav" `List.isSuffixOf`)) [[Char]]
fns) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ SynthName
"waveforms resolved to non-wav: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map WaveformChunk -> [Char]
Track._filename [WaveformChunk]
waveforms) [[Char]]
fns)
        [[Char]]
fns2 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> IO [Char]
resolve_link forall b c a. (b -> c) -> (a -> b) -> a -> c
. WaveformChunk -> [Char]
Track._filename) [WaveformChunk]
waveforms
        forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ SynthName
"tried again:"
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map WaveformChunk -> [Char]
Track._filename [WaveformChunk]
waveforms) [[Char]]
fns2)

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BlockId -> Set TrackId -> ImStatus -> DeriveStatus
Msg.ImStatus BlockId
block_id Set TrackId
track_ids forall a b. (a -> b) -> a -> b
$ [WaveformChunk] -> ImStatus
Msg.ImWaveformsCompleted
        [WaveformChunk
wave { _filename :: [Char]
Track._filename = [Char]
fn } | ([Char]
fn, WaveformChunk
wave) <- forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
fns [WaveformChunk]
waveforms]
resolve_waveform_links DeriveStatus
status = forall (m :: * -> *) a. Monad m => a -> m a
return DeriveStatus
status

resolve_link :: FilePath -> IO FilePath
resolve_link :: [Char] -> IO [Char]
resolve_link [Char]
fname = do
    [Char]
dest <- [Char] -> IO [Char]
Directory.getSymbolicLinkTarget [Char]
fname
    [Char]
dest <- if [Char]
"checkpoint/" forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` [Char]
dest
            Bool -> Bool -> Bool
&& [Char]
".wav" forall a. Eq a => [a] -> [a] -> Bool
`List.isSuffixOf` [Char]
dest
        then forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
dest
        else do
            [Char]
dest2 <- [Char] -> IO [Char]
Directory.getSymbolicLinkTarget [Char]
fname
            forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ SynthName
"bad symlink: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt [Char]
fname forall a. Semigroup a => a -> a -> a
<> SynthName
" -> " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt [Char]
dest
                forall a. Semigroup a => a -> a -> a
<> SynthName
", next time: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt [Char]
dest2
            forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
dest2
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ShowS
FilePath.takeDirectory [Char]
fname [Char] -> ShowS
</> [Char]
dest

-- resolve_link :: FilePath -> IO FilePath
-- resolve_link fname =
--     (FilePath.takeDirectory fname </>) <$> Directory.getSymbolicLinkTarget fname

real_to_score :: Transport.InverseTempoFunction -> BlockId -> Set TrackId
    -> RealTime -> Maybe ScoreTime
real_to_score :: InverseTempoFunction
-> BlockId -> Set TrackId -> RealTime -> Maybe TrackTime
real_to_score InverseTempoFunction
inv_tempo BlockId
block_id Set TrackId
track_ids =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
track_ids) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup BlockId
block_id
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. InverseTempoFunction
inv_tempo Stop
Transport.NoStop

-- | If there are im events, serialize them and return a Processes to render
-- them, and the non-im events.
evaluate_im :: Config.Config
    -> (ScoreT.Instrument -> Maybe Cmd.ResolvedInstrument)
    -> FilePath -> RealTime -> RealTime -> BlockId -> Vector.Vector Score.Event
    -> IO ([Process], Vector.Vector Score.Event)
evaluate_im :: Config
-> (Instrument -> Maybe ResolvedInstrument)
-> [Char]
-> RealTime
-> RealTime
-> BlockId
-> Vector Event
-> IO ([Process], Vector Event)
evaluate_im Config
config Instrument -> Maybe ResolvedInstrument
lookup_inst [Char]
score_path RealTime
adjust0 RealTime
play_multiplier BlockId
block_id
        Vector Event
events = do
    [Process]
procs <- forall a. [Maybe a] -> [a]
Maybe.catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe SynthName, Vector Event) -> IO (Maybe Process)
write_notes [(Maybe SynthName, Vector Event)]
by_synth
    [Char] -> HashSet Instrument -> IO ()
Config.clearUnusedInstruments [Char]
output_dir HashSet Instrument
instruments
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Process]
procs, forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup forall a. Maybe a
Nothing [(Maybe SynthName, Vector Event)]
by_synth)
    where
    instruments :: HashSet Instrument
instruments = forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' HashSet Instrument -> Event -> HashSet Instrument
add forall a. Monoid a => a
mempty Vector Event
events
        where add :: HashSet Instrument -> Event -> HashSet Instrument
add = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument
    by_synth :: [(Maybe SynthName, Vector Event)]
by_synth = forall key (v :: * -> *) a.
(Eq key, Vector v a) =>
(a -> key) -> v a -> [(key, v a)]
Util.Vector.partition_on Event -> Maybe SynthName
im_synth Vector Event
events
    lookup_im :: Instrument -> Maybe ResolvedInstrument
lookup_im Instrument
inst = case Instrument -> Maybe ResolvedInstrument
lookup_inst Instrument
inst of
        Just ResolvedInstrument
inst
            | Inst.Inst (Inst.Im {}) Common InstrumentCode
_  <- ResolvedInstrument -> Inst InstrumentCode
Cmd.inst_instrument ResolvedInstrument
inst ->
                forall a. a -> Maybe a
Just ResolvedInstrument
inst
        Maybe ResolvedInstrument
_ -> forall a. Maybe a
Nothing
    im_synth :: Event -> Maybe SynthName
im_synth = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ResolvedInstrument -> SynthName
Cmd.inst_synth forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instrument -> Maybe ResolvedInstrument
lookup_im forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument

    output_dir :: [Char]
output_dir = [Char] -> [Char] -> BlockId -> [Char]
Config.outputDirectory (Config -> [Char]
Config.imDir Config
config) [Char]
score_path
        BlockId
block_id
    write_notes :: (Maybe SynthName, Vector Event) -> IO (Maybe Process)
write_notes (Just SynthName
synth_name, Vector Event
events) =
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SynthName
synth_name (Config -> Map SynthName Synth
Config.synths Config
config) of
            Just Synth
synth -> do
                let notes_file :: [Char]
notes_file = [Char] -> [Char] -> BlockId -> Synth -> [Char]
Config.notesFilename (Config -> [Char]
Config.imDir Config
config)
                        [Char]
score_path BlockId
block_id Synth
synth
                -- I used to get the changed flag out of Im.Convert.write and
                -- skip the subprocess if it hadn't changed.  But that gets in
                -- the way of getting waveforms on the first run (assuming the
                -- notes haven't been touched since).  In any case, I'm now
                -- more careful in insert_damage, so we shouldn't even get here
                -- unless there was damage on the block, and if there was but
                -- notes haven't changed, the im synth should hit its cache.
                RealTime
-> RealTime
-> BlockId
-> (Instrument -> Maybe ResolvedInstrument)
-> [Char]
-> Vector Event
-> IO ()
Im.Convert.write RealTime
adjust0 RealTime
play_multiplier BlockId
block_id
                    Instrument -> Maybe ResolvedInstrument
lookup_inst [Char]
notes_file Vector Event
events
                let binary :: [Char]
binary = Synth -> [Char]
Config.binary Synth
synth
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
binary
                    then forall a. Maybe a
Nothing
                    else forall a. a -> Maybe a
Just ([Char]
binary, [[Char]
"--progress", [Char]
notes_file, [Char]
output_dir])
            Maybe Synth
Nothing -> do
                forall (m :: * -> *). (Stack, LogMonad m) => SynthName -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ SynthName
"unknown im synth " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt SynthName
synth_name forall a. Semigroup a => a -> a -> a
<> SynthName
" with "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> SynthName
showt (forall a. Vector a -> ChunkNum
Vector.length Vector Event
events) forall a. Semigroup a => a -> a -> a
<> SynthName
" events"
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    write_notes (Maybe SynthName
Nothing, Vector Event
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | If there are no UiConfig.Im instruments, then I don't need to bother to
-- partition out its events.  However, it means I won't get errors if there
-- happen to be any, but I'll worry about that if it becomes a problem.
im_allocated :: UiConfig.Allocations -> Bool
im_allocated :: Allocations -> Bool
im_allocated (UiConfig.Allocations Map Instrument Allocation
allocs) =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Eq a => a -> a -> Bool
==Backend
UiConfig.Im) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> Backend
UiConfig.alloc_backend) (forall k a. Map k a -> [a]
Map.elems Map Instrument Allocation
allocs)

-- | Make a broken performance with just an error msg.  This ensures that
-- the msg is logged when you try to play, but will still suppress further
-- performance, so you don't get a million msgs.
broken_performance :: Text -> Cmd.Performance
broken_performance :: SynthName -> Performance
broken_performance SynthName
msg = Cmd.Performance
    { perf_derive_cache :: Cache
perf_derive_cache = forall a. Monoid a => a
mempty
    , perf_events :: Vector Event
perf_events = forall a. Monoid a => a
mempty
    , perf_logs :: [Msg]
perf_logs = [Stack => Priority -> Maybe Stack -> SynthName -> Msg
Log.msg Priority
Log.Warn forall a. Maybe a
Nothing SynthName
msg]
    , perf_logs_written :: Bool
perf_logs_written = Bool
False
    , perf_track_dynamic :: TrackDynamic
perf_track_dynamic = forall a. Monoid a => a
mempty
    , perf_integrated :: [Integrated]
perf_integrated = forall a. Monoid a => a
mempty
    , perf_damage :: ScoreDamage
perf_damage = forall a. Monoid a => a
mempty
    , perf_warps :: [TrackWarp]
perf_warps = forall a. Monoid a => a
mempty
    , perf_track_signals :: TrackSignals
perf_track_signals = forall a. Monoid a => a
mempty
    , perf_block_deps :: BlockDeps
perf_block_deps = forall a. Monoid a => a
mempty
    , perf_track_instruments :: Map TrackId (Set Instrument)
perf_track_instruments = forall a. Monoid a => a
mempty
    , perf_ui_state :: State
perf_ui_state = State
Ui.empty
    }

-- | Constructor for 'Cmd.Performance'.
performance :: Ui.State -> Derive.Result -> Cmd.Performance
performance :: State -> Result -> Performance
performance State
state Result
result = Cmd.Performance
    { perf_derive_cache :: Cache
perf_derive_cache = Result -> Cache
Derive.r_cache Result
result
    , perf_events :: Vector Event
perf_events = Vector Event
vevents
    , perf_logs :: [Msg]
perf_logs = [Msg]
logs
    , perf_logs_written :: Bool
perf_logs_written = Bool
False
    , perf_track_dynamic :: TrackDynamic
perf_track_dynamic = Result -> TrackDynamic
Derive.r_track_dynamic Result
result
    , perf_integrated :: [Integrated]
perf_integrated = Result -> [Integrated]
Derive.r_integrated Result
result
    , perf_damage :: ScoreDamage
perf_damage = forall a. Monoid a => a
mempty
    , perf_warps :: [TrackWarp]
perf_warps = Result -> [TrackWarp]
Derive.r_track_warps Result
result
    , perf_track_signals :: TrackSignals
perf_track_signals = Result -> TrackSignals
Derive.r_track_signals Result
result
    , perf_block_deps :: BlockDeps
perf_block_deps = Collect -> BlockDeps
Derive.collect_block_deps forall a b. (a -> b) -> a -> b
$ State -> Collect
Derive.state_collect forall a b. (a -> b) -> a -> b
$
        Result -> State
Derive.r_state Result
result
    , perf_track_instruments :: Map TrackId (Set Instrument)
perf_track_instruments = Vector Event -> [TrackId] -> Map TrackId (Set Instrument)
track_instruments
        Vector Event
vevents (forall k a. Map k a -> [k]
Map.keys (State -> Map TrackId Track
Ui.state_tracks State
state))
    , perf_ui_state :: State
perf_ui_state = State
state
    }
    where
    vevents :: Vector Event
vevents = forall a. [a] -> Vector a
Vector.fromList [Event]
events
    ([Event]
events, [Msg]
logs) = forall a. Stream a -> ([a], [Msg])
Stream.partition (Result -> Stream Event
Derive.r_events Result
result)

modify_play_state :: (Cmd.PlayState -> Cmd.PlayState) -> Cmd.State -> Cmd.State
modify_play_state :: (PlayState -> PlayState) -> State -> State
modify_play_state PlayState -> PlayState
modify State
state =
    State
state { state_play :: PlayState
Cmd.state_play = PlayState -> PlayState
modify (State -> PlayState
Cmd.state_play State
state) }

track_instruments :: Vector.Vector Score.Event -> [TrackId]
    -> Map TrackId (Set ScoreT.Instrument)
track_instruments :: Vector Event -> [TrackId] -> Map TrackId (Set Instrument)
track_instruments Vector Event
events = forall k a. Eq k => [(k, a)] -> Map k a
Map.Lazy.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> k) -> [a] -> [(a, k)]
Lists.keyOnSnd TrackId -> Set Instrument
instruments_of
    -- fromAscList should be safe since Map.keys returns in order.
    where
    -- Go by TrackId, so I can make each Map value lazy, since I will only
    -- even need the instruments if I do an im mute on the track.
    instruments_of :: TrackId -> Set Instrument
instruments_of TrackId
track_id = forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (TrackId -> Set Instrument -> Event -> Set Instrument
get TrackId
track_id) forall a. Monoid a => a
mempty Vector Event
events
    get :: TrackId -> Set Instrument -> Event -> Set Instrument
get TrackId
track_id Set Instrument
seen Event
event
        | TrackId
track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TrackId]
track_ids =
            forall a. Ord a => a -> Set a -> Set a
Set.insert (Event -> Instrument
Score.event_instrument Event
event) Set Instrument
seen
        | Bool
otherwise = Set Instrument
seen
        where track_ids :: [TrackId]
track_ids = Stack -> [TrackId]
Stack.track_ids_of (Event -> Stack
Score.event_stack Event
event)

-- * util

-- | Like `S.mapM_` but with state.
s_mapAccumL_ :: Monad m => (st -> a -> m st) -> st -> S.Stream (S.Of a) m r
    -> m r
s_mapAccumL_ :: forall (m :: * -> *) st a r.
Monad m =>
(st -> a -> m st) -> st -> Stream (Of a) m r -> m r
s_mapAccumL_ st -> a -> m st
f = forall {b}. st -> Stream (Of a) m b -> m b
go
    where
    go :: st -> Stream (Of a) m b -> m b
go st
st Stream (Of a) m b
xs = forall (m :: * -> *) a r.
Monad m =>
Stream (Of a) m r -> m (Either r (a, Stream (Of a) m r))
S.next Stream (Of a) m b
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left b
r -> forall (m :: * -> *) a. Monad m => a -> m a
return b
r
        Right (a
x, Stream (Of a) m b
xs) -> do
            st
st <- st -> a -> m st
f st
st a
x
            st -> Stream (Of a) m b -> m b
go st
st Stream (Of a) m b
xs