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

-- | This module is responsible for actually scheduling MIDI messages with the
-- OS's MIDI driver.
module Perform.Midi.Play (State(..), play, cycle_messages) where
import qualified Control.Exception as Exception
import qualified Data.Maybe as Maybe

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Thread as Thread

import qualified Cmd.Cmd as Cmd
import qualified Derive.LEvent as LEvent
import qualified Midi.Interface as Interface
import qualified Midi.Midi as Midi
import qualified Midi.Mmc as Mmc

import qualified Perform.RealTime as RealTime
import qualified Perform.Transport as Transport

import           Global
import           Types


-- | Access to info that's needed by a particular run of the player.
-- This is read-only, and shouldn't need to be modified.
data State = State {
    -- | Communicate into the player.
    State -> PlayControl
_play_control :: !Transport.PlayControl
    -- | Communicate out from the player.
    , State -> ActivePlayers
_players :: !Transport.ActivePlayers
    , State -> Info
_info :: !Transport.Info
    , State -> Maybe RealTime
_im_end :: !(Maybe RealTime)
    }

type Messages = [LEvent.LEvent Midi.WriteMessage]

-- | Start a thread to stream a list of WriteMessages.
play :: State -> Maybe Cmd.SyncConfig -> Text -> Messages -> Maybe RealTime
    -- ^ If given, loop back to the beginning when this time is reached.
    -> IO ()
play :: State
-> Maybe SyncConfig -> Text -> Messages -> Maybe RealTime -> IO ()
play State
state Maybe SyncConfig
sync Text
name Messages
msgs Maybe RealTime
repeat_at = do
    RealTime
now <- Info -> IO RealTime
Transport.info_get_current_time (State -> Info
_info State
state)
    ActivePlayers -> IO ()
Transport.player_started (State -> ActivePlayers
_players State
state)
    String -> IO () -> IO ThreadId
Thread.startLogged String
"render midi" forall a b. (a -> b) -> a -> b
$ RealTime -> IO ()
thread RealTime
now
        forall a b. IO a -> IO b -> IO a
`Exception.finally` ActivePlayers -> IO ()
Transport.player_stopped (State -> ActivePlayers
_players State
state)
    forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where
    thread :: RealTime -> IO ()
thread RealTime
now = Maybe SyncConfig -> RealTime -> Text -> State -> Messages -> IO ()
player_thread
        -- Don't send MMC if I'm repeating, it'll just confuse the DAW.
        (if forall a. Maybe a -> Bool
Maybe.isJust Maybe RealTime
repeat_at then forall a. Maybe a
Nothing else Maybe SyncConfig
sync)
        RealTime
now Text
name
        (State
state { _im_end :: Maybe RealTime
_im_end = (RealTime
now+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State -> Maybe RealTime
_im_end State
state })
        (RealTime -> Maybe RealTime -> Messages -> Messages
process RealTime
now Maybe RealTime
repeat_at Messages
msgs)
    -- Catch msgs up to realtime and cycle them if I'm repeating.
    process :: RealTime -> Maybe RealTime -> Messages -> Messages
process RealTime
now Maybe RealTime
repeat_at = RealTime -> Messages -> Messages
shift_messages RealTime
now
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id RealTime -> Messages -> Messages
cycle_messages Maybe RealTime
repeat_at

player_thread :: Maybe Cmd.SyncConfig -> RealTime -> Text -> State
    -> Messages -> IO ()
player_thread :: Maybe SyncConfig -> RealTime -> Text -> State -> Messages -> IO ()
player_thread Maybe SyncConfig
maybe_sync RealTime
start Text
name State
state Messages
msgs = do
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ Text
"play start: " forall a. Semigroup a => a -> a -> a
<> Text
name
    case Maybe SyncConfig
maybe_sync of
        Just SyncConfig
sync | Bool -> Bool
not (SyncConfig -> Bool
Cmd.sync_mtc SyncConfig
sync) ->
            State -> WriteMessage -> IO ()
state_write_midi State
state forall a b. (a -> b) -> a -> b
$ SyncConfig -> RealTime -> Mmc -> WriteMessage
make_mmc SyncConfig
sync RealTime
start Mmc
Mmc.Play
        Maybe SyncConfig
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    State -> Messages -> IO ()
play_loop State
state Messages
msgs
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` \(SomeException
exc :: Exception.SomeException) ->
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text
"player died: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc)
    case Maybe SyncConfig
maybe_sync of
        Just SyncConfig
sync | Bool -> Bool
not (SyncConfig -> Bool
Cmd.sync_mtc SyncConfig
sync) ->
            State -> WriteMessage -> IO ()
state_write_midi State
state forall a b. (a -> b) -> a -> b
$ SyncConfig -> RealTime -> Mmc -> WriteMessage
make_mmc SyncConfig
sync RealTime
start Mmc
Mmc.Stop
        Maybe SyncConfig
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ Text
"play complete: " forall a. Semigroup a => a -> a -> a
<> Text
name

make_mmc :: Cmd.SyncConfig -> RealTime -> Mmc.Mmc -> Midi.WriteMessage
make_mmc :: SyncConfig -> RealTime -> Mmc -> WriteMessage
make_mmc SyncConfig
sync RealTime
start Mmc
msg = WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage (SyncConfig -> WriteDevice
Cmd.sync_device SyncConfig
sync) RealTime
start forall a b. (a -> b) -> a -> b
$
    DeviceId -> Mmc -> Message
Mmc.encode (SyncConfig -> DeviceId
Cmd.sync_device_id SyncConfig
sync) Mmc
msg

cycle_messages :: RealTime -> Messages -> Messages
cycle_messages :: RealTime -> Messages -> Messages
cycle_messages RealTime
_ [] = []
cycle_messages RealTime
repeat_at Messages
msgs =
    Messages -> Messages
go1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall d. (d -> Bool) -> LEvent d -> Bool
LEvent.log_or ((forall a. Ord a => a -> a -> Bool
<RealTime
repeat_at) forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriteMessage -> RealTime
Midi.wmsg_ts)) Messages
msgs
    where
    go1 :: Messages -> Messages
go1 Messages
msgs = Messages
msgs forall a. [a] -> [a] -> [a]
++ Messages -> Messages
go (RealTime -> Messages -> Messages
shift_messages RealTime
repeat_at (forall {a}. [LEvent a] -> [LEvent a]
strip Messages
msgs))
    -- Don't bother writing logs the second time around.
    go :: Messages -> Messages
go [] = []
    go Messages
msgs = Messages
msgs forall a. [a] -> [a] -> [a]
++ Messages -> Messages
go (RealTime -> Messages -> Messages
shift_messages RealTime
repeat_at Messages
msgs)
    strip :: [LEvent a] -> [LEvent a]
strip = forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. [LEvent d] -> [d]
LEvent.events_of

shift_messages :: RealTime -> Messages -> Messages
shift_messages :: RealTime -> Messages -> Messages
shift_messages RealTime
ts = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> WriteMessage -> WriteMessage
Midi.add_timestamp RealTime
ts))

-- * loop

-- | 'play_loop' tries to not get too far ahead of now both to avoid flooding
-- the midi driver and so a stop will happen fairly quickly.
write_ahead :: RealTime
write_ahead :: RealTime
write_ahead = Double -> RealTime
RealTime.seconds Double
1

state_write :: State -> Interface.Message -> IO ()
state_write :: State -> Message -> IO ()
state_write State
state = Info -> Message -> IO ()
Transport.info_midi_writer (State -> Info
_info State
state)

state_write_midi :: State -> Midi.WriteMessage -> IO ()
state_write_midi :: State -> WriteMessage -> IO ()
state_write_midi State
state = State -> Message -> IO ()
state_write State
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriteMessage -> Message
Interface.Midi

-- | @devs@ keeps track of devices that have been seen, so I know which devices
-- to reset.
play_loop :: State -> Messages -> IO ()
play_loop :: State -> Messages -> IO ()
play_loop State
state Messages
msgs = do
    -- This should make the buffer always be between write_ahead*2 and
    -- write_ahead ahead of now.
    RealTime
now <- Info -> IO RealTime
Transport.info_get_current_time (State -> Info
_info State
state)
    let until :: RealTime
until = RealTime
now forall a. Num a => a -> a -> a
+ RealTime -> Double -> RealTime
RealTime.mul RealTime
write_ahead Double
2
    let (Messages
chunk, Messages
rest) =
            forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a
LEvent.either ((forall a. Ord a => a -> a -> Bool
<RealTime
until) forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriteMessage -> RealTime
Midi.wmsg_ts) (forall a b. a -> b -> a
const Bool
True)) Messages
msgs
    -- Log.debug $ "play at " ++ show now ++ " chunk: " ++ show (length chunk)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a
LEvent.either (State -> WriteMessage -> IO ()
state_write_midi State
state) forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write) Messages
chunk

    -- Even if all the events have been scheduled, don't quit until they should
    -- have been played, so the monitor will hang on as long as there are still
    -- notes that can be cancelled.
    -- when (null rest) $
    --     putStrLn $ "MIDI end delay: " <> show (_im_end state) <> ": "
    --         <> show (get_end now chunk - now)
    let timeout :: RealTime
timeout = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Messages
rest then RealTime -> Messages -> RealTime
get_end RealTime
now Messages
chunk forall a. Num a => a -> a -> a
- RealTime
now else RealTime
write_ahead
    Bool
stop <- Seconds -> PlayControl -> IO Bool
Transport.poll_stop_player (RealTime -> Seconds
RealTime.to_diff RealTime
timeout)
        (State -> PlayControl
_play_control State
state)
    let reset_midi :: IO ()
reset_midi = State -> Message -> IO ()
state_write State
state (RealTime -> Message
Interface.AllNotesOff RealTime
now)
    case (Bool
stop, Messages
rest) of
        (Bool
True, Messages
_) -> do
            Info -> IO ()
Transport.info_midi_abort (State -> Info
_info State
state)
            IO ()
reset_midi
        -- I used to reset when MIDI ran out, and previously was correct
        -- because it only sent specific note offs, but if I use a real
        -- AllNotesOff then it breaks im.  I could have im not use AllNotesOff,
        -- but let's just remove the reset_midi here.
        (Bool
_, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- reset_midi
        (Bool, Messages)
_ -> State -> Messages -> IO ()
play_loop State
state Messages
rest
    where
    get_end :: RealTime -> Messages -> RealTime
get_end RealTime
now Messages
chunk = forall a. a -> Maybe a -> a
fromMaybe RealTime
now forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max
        (WriteMessage -> RealTime
Midi.wmsg_ts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
Lists.last (forall d. [LEvent d] -> [d]
LEvent.events_of Messages
chunk))
        (State -> Maybe RealTime
_im_end State
state)