{- | Background-thread transport for playing back a whole 'Song' with
pause\/resume\/stop, driven from the UI without blocking it.

The design: 'startPlayback' forks one \"tick\" thread that walks the
song's measures\/beats and sleeps between them; all coordination with
that thread happens through the STM 'TVar's in 'PlaybackEnv' rather than
by killing and restarting it on every command — 'pausePlayback',
'stopPlayback', and 'resumePlayback' just post a 'PlaybackCommand' that
the tick thread notices between beats (see @playMeasureBeats@ in the
internals). 'startPlayback' is the one exception: it kills any
already-running tick thread before forking a new one, since \"start\"
means \"play from here,\" not \"resume.\"
-}
module Termtab.Audio.PlaybackThread (
    PlaybackCommand (..),
    PlaybackEnv (..),
    initPlaybackEnv,
    destroyPlaybackEnv,
    startPlayback,
    pausePlayback,
    stopPlayback,
    resumePlayback,
) where

import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
import Control.Concurrent.STM
import Control.Exception (SomeException, catch)
import Control.Monad (forM_)
import Data.Map.Strict qualified as Map

import Termtab.Audio (AudioEngine, engineNoteOff, engineNoteOn, startAudioEngine, stopAudioEngine)
import Termtab.Audio.Playback (durationToMicroseconds)
import Termtab.Audio.Types (AudioConfig, BackendType (..), PlaybackStatus (..))
import Termtab.Types

{- | A message posted to 'peCommandVar' for the running tick thread to act
on at its next beat boundary. Distinct from
'Termtab.Audio.Types.AudioCommand' — that type is for a queue-based
design that isn't what this module implements; this one is consumed
directly out of a single-slot 'TVar'.
-}
data PlaybackCommand
    = CmdStartPlayback MeasureIndex
    | CmdPausePlayback
    | CmdStopPlayback
    deriving (Int -> PlaybackCommand -> ShowS
[PlaybackCommand] -> ShowS
PlaybackCommand -> String
(Int -> PlaybackCommand -> ShowS)
-> (PlaybackCommand -> String)
-> ([PlaybackCommand] -> ShowS)
-> Show PlaybackCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PlaybackCommand -> ShowS
showsPrec :: Int -> PlaybackCommand -> ShowS
$cshow :: PlaybackCommand -> String
show :: PlaybackCommand -> String
$cshowList :: [PlaybackCommand] -> ShowS
showList :: [PlaybackCommand] -> ShowS
Show, PlaybackCommand -> PlaybackCommand -> Bool
(PlaybackCommand -> PlaybackCommand -> Bool)
-> (PlaybackCommand -> PlaybackCommand -> Bool)
-> Eq PlaybackCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PlaybackCommand -> PlaybackCommand -> Bool
== :: PlaybackCommand -> PlaybackCommand -> Bool
$c/= :: PlaybackCommand -> PlaybackCommand -> Bool
/= :: PlaybackCommand -> PlaybackCommand -> Bool
Eq)

{- | Shared state between the caller (typically the UI) and the tick
thread forked by 'startPlayback'. All fields are 'TVar's so both sides
can read\/write them without explicit locking.
-}
data PlaybackEnv = PlaybackEnv
    { PlaybackEnv -> AudioEngine
peAudioEngine :: AudioEngine
    , PlaybackEnv -> TVar (MeasureIndex, BeatIndex)
pePositionVar :: TVar (MeasureIndex, BeatIndex)
    , PlaybackEnv -> TVar (Maybe PlaybackCommand)
peCommandVar :: TVar (Maybe PlaybackCommand)
    , PlaybackEnv -> TVar PlaybackStatus
peStatusVar :: TVar PlaybackStatus
    , PlaybackEnv -> IO ()
peNotify :: IO ()
    -- ^ Called after each position update to wake the UI
    , PlaybackEnv -> TVar (Maybe ThreadId)
peThreadId :: TVar (Maybe ThreadId)
    }

{- | Start a FluidSynth 'AudioEngine' with @cfg@ and build a fresh,
stopped 'PlaybackEnv' around it. @notify@ is stashed as 'peNotify' and
invoked by the tick thread on every position/status change — pass
whatever hook wakes the UI's event loop (e.g. a Brick @BChan@ write).
-}
initPlaybackEnv :: AudioConfig -> IO () -> IO PlaybackEnv
initPlaybackEnv :: AudioConfig -> IO () -> IO PlaybackEnv
initPlaybackEnv AudioConfig
cfg IO ()
notify = do
    engine <- BackendType -> AudioConfig -> IO AudioEngine
startAudioEngine BackendType
BackendFluidSynth AudioConfig
cfg
    posVar <- newTVarIO (MeasureIndex 0, BeatIndex 0)
    cmdVar <- newTVarIO Nothing
    statusVar <- newTVarIO Stopped
    tidVar <- newTVarIO Nothing
    return
        PlaybackEnv
            { peAudioEngine = engine
            , pePositionVar = posVar
            , peCommandVar = cmdVar
            , peStatusVar = statusVar
            , peNotify = notify
            , peThreadId = tidVar
            }

{- | Kill any running tick thread and shut down the underlying
'AudioEngine'. Call this once when playback is no longer needed at all
(not for pausing — use 'pausePlayback' for that).
-}
destroyPlaybackEnv :: PlaybackEnv -> IO ()
destroyPlaybackEnv :: PlaybackEnv -> IO ()
destroyPlaybackEnv PlaybackEnv
env = do
    mTid <- STM (Maybe ThreadId) -> IO (Maybe ThreadId)
forall a. STM a -> IO a
atomically (STM (Maybe ThreadId) -> IO (Maybe ThreadId))
-> STM (Maybe ThreadId) -> IO (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe ThreadId) -> STM (Maybe ThreadId)
forall a. TVar a -> STM a
readTVar (PlaybackEnv -> TVar (Maybe ThreadId)
peThreadId PlaybackEnv
env)
    mapM_ killThread mTid
    stopAudioEngine (peAudioEngine env)

{- | Kill any tick thread already running under @env@, then fork a fresh
one (@tickThread@) that plays @song@ starting at @startMeasure@ from
beat 0. Marks 'peStatusVar' 'Playing' immediately, without waiting for
the new thread to actually begin.
-}
startPlayback :: PlaybackEnv -> Song -> MeasureIndex -> IO ()
startPlayback :: PlaybackEnv -> Song -> MeasureIndex -> IO ()
startPlayback PlaybackEnv
env Song
song MeasureIndex
startMeasure = do
    -- Kill any existing thread
    mOldTid <- STM (Maybe ThreadId) -> IO (Maybe ThreadId)
forall a. STM a -> IO a
atomically (STM (Maybe ThreadId) -> IO (Maybe ThreadId))
-> STM (Maybe ThreadId) -> IO (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe ThreadId) -> STM (Maybe ThreadId)
forall a. TVar a -> STM a
readTVar (PlaybackEnv -> TVar (Maybe ThreadId)
peThreadId PlaybackEnv
env)
    mapM_ killThread mOldTid
    -- Spawn tick thread
    tid <- forkIO $ tickThread env song startMeasure
    atomically $ do
        writeTVar (peThreadId env) (Just tid)
        writeTVar (peStatusVar env) Playing

{- | Ask the running tick thread to pause at its next beat boundary
(silences all notes and records the current position; does not stop the
thread). No-op if nothing is playing.
-}
pausePlayback :: PlaybackEnv -> IO ()
pausePlayback :: PlaybackEnv -> IO ()
pausePlayback PlaybackEnv
env =
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TVar (Maybe PlaybackCommand) -> Maybe PlaybackCommand -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar (Maybe PlaybackCommand)
peCommandVar PlaybackEnv
env) (PlaybackCommand -> Maybe PlaybackCommand
forall a. a -> Maybe a
Just PlaybackCommand
CmdPausePlayback)

{- | Ask the running tick thread to stop at its next beat boundary
(silences all notes and resets 'peStatusVar' to 'Stopped'). Unlike
'startPlayback', this does not kill the thread directly — it just posts
the command and lets the thread exit on its own.
-}
stopPlayback :: PlaybackEnv -> IO ()
stopPlayback :: PlaybackEnv -> IO ()
stopPlayback PlaybackEnv
env =
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TVar (Maybe PlaybackCommand) -> Maybe PlaybackCommand -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar (Maybe PlaybackCommand)
peCommandVar PlaybackEnv
env) (PlaybackCommand -> Maybe PlaybackCommand
forall a. a -> Maybe a
Just PlaybackCommand
CmdStopPlayback)

{- | Resume a thread that is currently blocked waiting inside
'waitForResume' after a pause, continuing from measure @mi@ (in practice
the measure it was paused at). Has no effect on a thread that isn't
paused, since nothing is polling 'peCommandVar' for a resume in that
state.
-}
resumePlayback :: PlaybackEnv -> MeasureIndex -> IO ()
resumePlayback :: PlaybackEnv -> MeasureIndex -> IO ()
resumePlayback PlaybackEnv
env MeasureIndex
mi =
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TVar (Maybe PlaybackCommand) -> Maybe PlaybackCommand -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar (Maybe PlaybackCommand)
peCommandVar PlaybackEnv
env) (PlaybackCommand -> Maybe PlaybackCommand
forall a. a -> Maybe a
Just (MeasureIndex -> PlaybackCommand
CmdStartPlayback MeasureIndex
mi))

-- Internal

{- | The forked thread body started by 'startPlayback'. Walks measures from
@startMi@ to the end of the song via @go@, delegating each measure's
beats to @playMeasureBeats@; any exception anywhere in that walk is
caught and turned into a clean 'Stopped' status rather than crashing the
thread silently.
-}
tickThread :: PlaybackEnv -> Song -> MeasureIndex -> IO ()
tickThread :: PlaybackEnv -> Song -> MeasureIndex -> IO ()
tickThread PlaybackEnv
env Song
song (MeasureIndex Int
startMi) =
    Tempo -> Int -> IO ()
go (Song -> Tempo
songTempo Song
song) Int
startMi
        IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_ :: SomeException) ->
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar PlaybackStatus -> PlaybackStatus -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar PlaybackStatus
peStatusVar PlaybackEnv
env) PlaybackStatus
Stopped
  where
    measures :: [Measure]
measures = Song -> [Measure]
songMeasures Song
song
    tracks :: [Track]
tracks = Song -> [Track]
songTracks Song
song
    totalMeasures :: Int
totalMeasures = [Measure] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Measure]
measures

    -- A measure's tracks can have differing beat-list lengths (e.g. one
    -- track subdivided into eighths, another left at quarters) and none of
    -- them may fill the full bar. playableBeatCount takes the longest
    -- actual beat list as the count to iterate, then pads it with
    -- beatDurWeight-derived "empty slots" so playback still occupies the
    -- full bar duration even when no track's beats add up to it.
    playableBeatCount :: Measure -> MeasureIndex -> Int
    playableBeatCount :: Measure -> MeasureIndex -> Int
playableBeatCount Measure
measure MeasureIndex
mi =
        let TimeSignature Int
num Int
_ = Measure -> TimeSignature
timeSignature Measure
measure
            getBeats :: Track -> [Beat]
getBeats Track
t = [Beat] -> ([Beat] -> [Beat]) -> Maybe [Beat] -> [Beat]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Beat] -> [Beat]
forall a. a -> a
id (MeasureIndex -> Map MeasureIndex [Beat] -> Maybe [Beat]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MeasureIndex
mi (Track -> Map MeasureIndex [Beat]
trackBeats Track
t))
            -- Use the longest beat list among all tracks
            maxActual :: Int
maxActual = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
num Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Track -> Int) -> [Track] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Beat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Beat] -> Int) -> (Track -> [Beat]) -> Track -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> [Beat]
getBeats) [Track]
tracks)
            longestBeats :: [Beat]
longestBeats = case (Track -> Bool) -> [Track] -> [Track]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Track
t -> [Beat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Track -> [Beat]
getBeats Track
t) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maxActual) [Track]
tracks of
                (Track
t : [Track]
_) -> Track -> [Beat]
getBeats Track
t
                [] -> []
            usedUnits :: Int
usedUnits = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Beat -> Int) -> [Beat] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Duration -> Int
beatDurWeight (Duration -> Int) -> (Beat -> Duration) -> Beat -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Beat -> Duration
beatDuration) [Beat]
longestBeats)
            totalUnits :: Int
totalUnits = Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4
            remainingUnits :: Int
remainingUnits = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
totalUnits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
usedUnits)
            emptySlots :: Int
emptySlots = Int
remainingUnits Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4
         in Int
maxActual Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
emptySlots

    -- Sixteenth-note units per Duration, used to measure how much of a
    -- bar's total capacity (num * 4 units, i.e. num quarter notes) a beat
    -- list actually accounts for.
    beatDurWeight :: Duration -> Int
    beatDurWeight :: Duration -> Int
beatDurWeight Duration
Whole = Int
16
    beatDurWeight Duration
Half = Int
8
    beatDurWeight Duration
Quarter = Int
4
    beatDurWeight Duration
Eighth = Int
2
    beatDurWeight Duration
Sixteenth = Int
1
    beatDurWeight Duration
Thirty2nd = Int
1
    beatDurWeight (Dotted Duration
d) = Duration -> Int
beatDurWeight Duration
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Duration -> Int
beatDurWeight Duration
d Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
    beatDurWeight (Triplet Duration
d) = Duration -> Int
beatDurWeight Duration
d Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3

    -- Advance measure by measure until mi runs off the end of the song,
    -- resetting to Stopped/position 0 at that point. currentTempo applies
    -- a measure's tempoChange (if any) going forward, so it persists as
    -- the accumulator tempo for measures that don't override it themselves.
    go :: Tempo -> Int -> IO ()
    go :: Tempo -> Int -> IO ()
go Tempo
_tempo Int
mi
        | Int
mi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
totalMeasures = do
            -- Song ended
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                TVar PlaybackStatus -> PlaybackStatus -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar PlaybackStatus
peStatusVar PlaybackEnv
env) PlaybackStatus
Stopped
                TVar (MeasureIndex, BeatIndex)
-> (MeasureIndex, BeatIndex) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar (MeasureIndex, BeatIndex)
pePositionVar PlaybackEnv
env) (Int -> MeasureIndex
MeasureIndex Int
0, Int -> BeatIndex
BeatIndex Int
0)
            PlaybackEnv -> IO ()
peNotify PlaybackEnv
env
    go Tempo
tempo Int
mi = do
        let measure :: Measure
measure = [Measure]
measures [Measure] -> Int -> Measure
forall a. HasCallStack => [a] -> Int -> a
!! Int
mi
            currentTempo :: Tempo
currentTempo = Tempo -> (Tempo -> Tempo) -> Maybe Tempo -> Tempo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Tempo
tempo Tempo -> Tempo
forall a. a -> a
id (Measure -> Maybe Tempo
tempoChange Measure
measure)
            totalBeats :: Int
totalBeats = Measure -> MeasureIndex -> Int
playableBeatCount Measure
measure (Int -> MeasureIndex
MeasureIndex Int
mi)
        completed <- Tempo -> MeasureIndex -> Int -> Int -> IO Bool
playMeasureBeats Tempo
currentTempo (Int -> MeasureIndex
MeasureIndex Int
mi) Int
0 Int
totalBeats
        if completed
            then go currentTempo (mi + 1)
            else return ()

    -- Play beatIdx .. numBeats-1 of measure mi, checking peCommandVar for
    -- a pending pause/stop before each beat. Returns True if the measure
    -- ran to completion (so `go` should advance to the next measure) and
    -- False if a stop command cut it short. A pause blocks in
    -- waitForResume and either continues this same beat range (resumed) or
    -- also returns False (stopped while paused).
    playMeasureBeats :: Tempo -> MeasureIndex -> Int -> Int -> IO Bool
    playMeasureBeats :: Tempo -> MeasureIndex -> Int -> Int -> IO Bool
playMeasureBeats Tempo
_tempo MeasureIndex
_mi Int
beatIdx Int
numBeats
        | Int
beatIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numBeats = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    playMeasureBeats Tempo
tempo MeasureIndex
mi Int
beatIdx Int
numBeats = do
        -- Check for commands
        mCmd <- STM (Maybe PlaybackCommand) -> IO (Maybe PlaybackCommand)
forall a. STM a -> IO a
atomically (STM (Maybe PlaybackCommand) -> IO (Maybe PlaybackCommand))
-> STM (Maybe PlaybackCommand) -> IO (Maybe PlaybackCommand)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe PlaybackCommand)
-> Maybe PlaybackCommand -> STM (Maybe PlaybackCommand)
forall a. TVar a -> a -> STM a
swapTVar (PlaybackEnv -> TVar (Maybe PlaybackCommand)
peCommandVar PlaybackEnv
env) Maybe PlaybackCommand
forall a. Maybe a
Nothing
        case mCmd of
            Just PlaybackCommand
CmdStopPlayback -> do
                PlaybackEnv -> [Track] -> IO ()
allNotesOff PlaybackEnv
env [Track]
tracks
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar PlaybackStatus -> PlaybackStatus -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar PlaybackStatus
peStatusVar PlaybackEnv
env) PlaybackStatus
Stopped
                PlaybackEnv -> IO ()
peNotify PlaybackEnv
env
                Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            Just PlaybackCommand
CmdPausePlayback -> do
                PlaybackEnv -> [Track] -> IO ()
allNotesOff PlaybackEnv
env [Track]
tracks
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    TVar PlaybackStatus -> PlaybackStatus -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar PlaybackStatus
peStatusVar PlaybackEnv
env) PlaybackStatus
Paused
                    TVar (MeasureIndex, BeatIndex)
-> (MeasureIndex, BeatIndex) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar (MeasureIndex, BeatIndex)
pePositionVar PlaybackEnv
env) (MeasureIndex
mi, Int -> BeatIndex
BeatIndex Int
beatIdx)
                PlaybackEnv -> IO ()
peNotify PlaybackEnv
env
                resumed <- PlaybackEnv -> IO Bool
waitForResume PlaybackEnv
env
                if resumed
                    then playMeasureBeats tempo mi beatIdx numBeats
                    else return False
            Maybe PlaybackCommand
_ -> do
                let bi :: BeatIndex
bi = Int -> BeatIndex
BeatIndex Int
beatIdx
                -- Update position
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (MeasureIndex, BeatIndex)
-> (MeasureIndex, BeatIndex) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar (MeasureIndex, BeatIndex)
pePositionVar PlaybackEnv
env) (MeasureIndex
mi, BeatIndex
bi)
                PlaybackEnv -> IO ()
peNotify PlaybackEnv
env

                -- Collect beat info and fire NoteOn
                let beatDur :: Duration
beatDur = [Track] -> MeasureIndex -> Int -> Duration
findBeatDuration [Track]
tracks MeasureIndex
mi Int
beatIdx
                [Track] -> (Track -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Track]
tracks ((Track -> IO ()) -> IO ()) -> (Track -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Track
track ->
                    case Track -> MeasureIndex -> Int -> Maybe Beat
getBeatAt Track
track MeasureIndex
mi Int
beatIdx of
                        Just Beat
beat | Bool -> Bool
not (Beat -> Bool
beatIsRest Beat
beat) ->
                            [Note] -> (Note -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Beat -> [Note]
beatNotes Beat
beat) ((Note -> IO ()) -> IO ()) -> (Note -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Note
note ->
                                AudioEngine -> MidiChannel -> Pitch -> Velocity -> IO ()
engineNoteOn
                                    (PlaybackEnv -> AudioEngine
peAudioEngine PlaybackEnv
env)
                                    (Track -> MidiChannel
trackChannel Track
track)
                                    (Note -> Pitch
notePitch Note
note)
                                    (Note -> Velocity
noteVelocity Note
note)
                        Maybe Beat
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                -- Wait for beat duration
                Int -> IO ()
threadDelay (Duration -> Tempo -> Int
durationToMicroseconds Duration
beatDur Tempo
tempo)

                -- Fire NoteOff
                [Track] -> (Track -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Track]
tracks ((Track -> IO ()) -> IO ()) -> (Track -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Track
track ->
                    case Track -> MeasureIndex -> Int -> Maybe Beat
getBeatAt Track
track MeasureIndex
mi Int
beatIdx of
                        Just Beat
beat | Bool -> Bool
not (Beat -> Bool
beatIsRest Beat
beat) ->
                            [Note] -> (Note -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Beat -> [Note]
beatNotes Beat
beat) ((Note -> IO ()) -> IO ()) -> (Note -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Note
note ->
                                AudioEngine -> MidiChannel -> Pitch -> IO ()
engineNoteOff
                                    (PlaybackEnv -> AudioEngine
peAudioEngine PlaybackEnv
env)
                                    (Track -> MidiChannel
trackChannel Track
track)
                                    (Note -> Pitch
notePitch Note
note)
                        Maybe Beat
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                Tempo -> MeasureIndex -> Int -> Int -> IO Bool
playMeasureBeats Tempo
tempo MeasureIndex
mi (Int
beatIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
numBeats

{- | Block (via STM @retry@) until a 'CmdStartPlayback' or 'CmdStopPlayback'
appears in 'peCommandVar' after a pause, updating 'peStatusVar'
accordingly. Returns 'True' to resume playback, 'False' to stop.
-}
waitForResume :: PlaybackEnv -> IO Bool
waitForResume :: PlaybackEnv -> IO Bool
waitForResume PlaybackEnv
env = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
    mCmd <- TVar (Maybe PlaybackCommand) -> STM (Maybe PlaybackCommand)
forall a. TVar a -> STM a
readTVar (PlaybackEnv -> TVar (Maybe PlaybackCommand)
peCommandVar PlaybackEnv
env)
    case mCmd of
        Just (CmdStartPlayback MeasureIndex
_) -> do
            TVar (Maybe PlaybackCommand) -> Maybe PlaybackCommand -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar (Maybe PlaybackCommand)
peCommandVar PlaybackEnv
env) Maybe PlaybackCommand
forall a. Maybe a
Nothing
            TVar PlaybackStatus -> PlaybackStatus -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar PlaybackStatus
peStatusVar PlaybackEnv
env) PlaybackStatus
Playing
            Bool -> STM Bool
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Just PlaybackCommand
CmdStopPlayback -> do
            TVar (Maybe PlaybackCommand) -> Maybe PlaybackCommand -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar (Maybe PlaybackCommand)
peCommandVar PlaybackEnv
env) Maybe PlaybackCommand
forall a. Maybe a
Nothing
            TVar PlaybackStatus -> PlaybackStatus -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PlaybackEnv -> TVar PlaybackStatus
peStatusVar PlaybackEnv
env) PlaybackStatus
Stopped
            Bool -> STM Bool
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Maybe PlaybackCommand
_ -> STM Bool
forall a. STM a
retry

{- | Look up the beat at position @beatIdx@ within measure @mi@ of a track,
or 'Nothing' if the track has no beats for that measure or the index is
past the end of its beat list (e.g. a shorter subdivision than the
measure's padded 'playableBeatCount').
-}
getBeatAt :: Track -> MeasureIndex -> Int -> Maybe Beat
getBeatAt :: Track -> MeasureIndex -> Int -> Maybe Beat
getBeatAt Track
track MeasureIndex
mi Int
beatIdx =
    case MeasureIndex -> Map MeasureIndex [Beat] -> Maybe [Beat]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MeasureIndex
mi (Track -> Map MeasureIndex [Beat]
trackBeats Track
track) of
        Just [Beat]
beats | Int
beatIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Beat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Beat]
beats -> Beat -> Maybe Beat
forall a. a -> Maybe a
Just ([Beat]
beats [Beat] -> Int -> Beat
forall a. HasCallStack => [a] -> Int -> a
!! Int
beatIdx)
        Maybe [Beat]
_ -> Maybe Beat
forall a. Maybe a
Nothing

{- | The 'Duration' to sleep for at a given beat position: the duration of
the first track that actually has a beat there (tracks are otherwise
assumed to agree on timing at a shared beat index), or 'Quarter' if no
track has one.
-}
findBeatDuration :: [Track] -> MeasureIndex -> Int -> Duration
findBeatDuration :: [Track] -> MeasureIndex -> Int -> Duration
findBeatDuration [Track]
tracks MeasureIndex
mi Int
beatIdx =
    let durations :: [Duration]
durations =
            [ Beat -> Duration
beatDuration Beat
b
            | Track
track <- [Track]
tracks
            , Just Beat
b <- [Track -> MeasureIndex -> Int -> Maybe Beat
getBeatAt Track
track MeasureIndex
mi Int
beatIdx]
            ]
     in case [Duration]
durations of
            [] -> Duration
Quarter
            (Duration
d : [Duration]
_) -> Duration
d

{- | Silence every possible MIDI pitch (0-127) on every track's channel.
Used on pause\/stop instead of tracking exactly which notes are
currently sounding, since that set isn't threaded through this module's
state.
-}
allNotesOff :: PlaybackEnv -> [Track] -> IO ()
allNotesOff :: PlaybackEnv -> [Track] -> IO ()
allNotesOff PlaybackEnv
env [Track]
tracks = do
    let channels :: [MidiChannel]
channels = (Track -> MidiChannel) -> [Track] -> [MidiChannel]
forall a b. (a -> b) -> [a] -> [b]
map Track -> MidiChannel
trackChannel [Track]
tracks
    [MidiChannel] -> (MidiChannel -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [MidiChannel]
channels ((MidiChannel -> IO ()) -> IO ())
-> (MidiChannel -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \MidiChannel
ch ->
        [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
127 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
p ->
            AudioEngine -> MidiChannel -> Pitch -> IO ()
engineNoteOff (PlaybackEnv -> AudioEngine
peAudioEngine PlaybackEnv
env) MidiChannel
ch (Int -> Pitch
Pitch Int
p)