-- 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

{- | The transport is the communication mechanism between the app and the
    performer.  Extensive description is in the Cmd.Play docstring.
-}
module Perform.Transport (
    -- * info
    Status(..), Info(..)
    -- * play control
    , PlayControl(..), play_control
    , stop_player, poll_stop_player
    -- * play monitor control
    , ActivePlayers, active_players
    , player_started, player_stopped
    , poll_player_stopped, wait_player_stopped
    -- * play timing
    , TempoFunction, ClosestWarpFunction, InverseTempoFunction, Stop(..)
) where
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TVar as TVar

import qualified Util.Thread as Thread
import qualified Derive.Warp as Warp
import qualified Midi.Interface as Interface
import qualified Ui.Ui as Ui

import           Global
import           Types


-- | These go back to the responder loop from the render thread to notify it
-- about the transport's state.
data Status = Playing | Stopped !PlayControl
    deriving (Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show)

instance Pretty Status where pretty :: Status -> Text
pretty = Status -> Text
forall a. Show a => a -> Text
showt

-- | Data needed by the MIDI player thread.  This is created during app setup
-- and passed directly to the play cmds by the responder loop.  When the play
-- is started, it's incorporated into the play 'Perform.Midi.Play.State'.
data Info = Info {
    -- | Send status messages back to the responder loop.
    Info -> Status -> IO ()
info_send_status :: Status -> IO ()
    , Info -> Message -> IO ()
info_midi_writer :: Interface.Message -> IO ()
    -- | Action that will abort any pending midi msgs written with the midi
    -- writer.
    , Info -> IO ()
info_midi_abort :: IO ()
    -- | Get current RealTime according to timing system.
    , Info -> IO RealTime
info_get_current_time :: IO RealTime
    -- | A mutable map of the currently active views, so the responder can
    -- tell the play monitor thread which views are currently opened.  It needs
    -- this so if you open a new view while it's playing, it can put the play
    -- selection on that view.
    , Info -> MVar State
info_state :: MVar.MVar Ui.State
    }

-- * play control

-- | Communication from the responder to the players, to tell them to stop.
newtype PlayControl = PlayControl Thread.Flag
    deriving (PlayControl -> PlayControl -> Bool
(PlayControl -> PlayControl -> Bool)
-> (PlayControl -> PlayControl -> Bool) -> Eq PlayControl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlayControl -> PlayControl -> Bool
$c/= :: PlayControl -> PlayControl -> Bool
== :: PlayControl -> PlayControl -> Bool
$c== :: PlayControl -> PlayControl -> Bool
Eq, Int -> PlayControl -> ShowS
[PlayControl] -> ShowS
PlayControl -> String
(Int -> PlayControl -> ShowS)
-> (PlayControl -> String)
-> ([PlayControl] -> ShowS)
-> Show PlayControl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlayControl] -> ShowS
$cshowList :: [PlayControl] -> ShowS
show :: PlayControl -> String
$cshow :: PlayControl -> String
showsPrec :: Int -> PlayControl -> ShowS
$cshowsPrec :: Int -> PlayControl -> ShowS
Show)

play_control :: IO PlayControl
play_control :: IO PlayControl
play_control = Flag -> PlayControl
PlayControl (Flag -> PlayControl) -> IO Flag -> IO PlayControl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Flag
Thread.flag

-- | Signal to the player that you'd like it to start stopping doing whatever
-- it is that it's doing and just like stop now ok?  Is that ok?
stop_player :: PlayControl -> IO ()
stop_player :: PlayControl -> IO ()
stop_player (PlayControl Flag
flag) = Flag -> IO ()
Thread.set Flag
flag

poll_stop_player :: Thread.Seconds -> PlayControl -> IO Bool
poll_stop_player :: Seconds -> PlayControl -> IO Bool
poll_stop_player Seconds
timeout (PlayControl Flag
flag) = Seconds -> Flag -> IO Bool
Thread.poll Seconds
timeout Flag
flag

-- * play monitor control

-- | Number of active players, this goes to zero when they are all complete.
newtype ActivePlayers = ActivePlayers (TVar.TVar Int)

active_players :: IO ActivePlayers
active_players :: IO ActivePlayers
active_players = TVar Int -> ActivePlayers
ActivePlayers (TVar Int -> ActivePlayers) -> IO (TVar Int) -> IO ActivePlayers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
TVar.newTVarIO Int
0

player_started :: ActivePlayers -> IO ()
player_started :: ActivePlayers -> IO ()
player_started (ActivePlayers TVar Int
running) =
    STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
TVar.modifyTVar' TVar Int
running (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

-- | Signal that a player has stopped.
player_stopped :: ActivePlayers -> IO ()
player_stopped :: ActivePlayers -> IO ()
player_stopped (ActivePlayers TVar Int
running) =
    STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
TVar.modifyTVar' TVar Int
running (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)

-- | True if all the players have stopped.
poll_player_stopped :: Thread.Seconds -> ActivePlayers -> IO Bool
poll_player_stopped :: Seconds -> ActivePlayers -> IO Bool
poll_player_stopped Seconds
timeout ctl :: ActivePlayers
ctl@(ActivePlayers TVar Int
running)
    | Seconds
timeout Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
<= Seconds
0 = (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
0) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Int -> IO Int
forall a. TVar a -> IO a
TVar.readTVarIO TVar Int
running
    | Bool
otherwise = Bool -> (() -> Bool) -> Maybe () -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> () -> Bool
forall a b. a -> b -> a
const Bool
True) (Maybe () -> Bool) -> IO (Maybe ()) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Seconds -> IO () -> IO (Maybe ())
forall a. Seconds -> IO a -> IO (Maybe a)
Thread.timeout Seconds
timeout (ActivePlayers -> IO ()
wait_player_stopped ActivePlayers
ctl)

wait_player_stopped :: ActivePlayers -> IO ()
wait_player_stopped :: ActivePlayers -> IO ()
wait_player_stopped (ActivePlayers TVar Int
running) = STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Int
val <- TVar Int -> STM Int
forall a. TVar a -> STM a
STM.readTVar TVar Int
running
    if Int
val Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else STM ()
forall a. STM a
STM.retry


-- * play timing

-- | Given a score time on a certain track in a certain block, give the real
-- times that it corresponds to.  There may be more than one if the block
-- has been derived in more than one place, and there may be zero if the block
-- and track combination wasn't derived at all or didn't extend to the given
-- score time.
type TempoFunction = BlockId -> TrackId -> ScoreTime -> [RealTime]

-- | This is similar to 'TempoFunction' but finds the warp for the given block
-- that occurs closest to the given RealTime.  Callers can use the warp to
-- find multiple real times on that block.
--
-- 'TempoFunction' simply returns all real times for a given score time, with
-- no control over whether they come from the same block or not.
type ClosestWarpFunction = BlockId -> TrackId -> RealTime -> Warp.Warp

-- | Return the ScoreTime play position in the various playing blocks at the
-- given physical time.  If the RealTime is past the end of all playing blocks,
-- return [].  The play monitor thread polls this periodically for all
-- displayed blocks and updates the play selection accordingly.
--
-- Since a given block may be playing in multiple places at the same time (e.g.
-- for a block that is played like an instrument, if the notes overlap), the
-- same BlockId may occur more than once in the output list.
type InverseTempoFunction =
    Stop -> RealTime -> [(BlockId, [(TrackId, ScoreTime)])]

-- | Configure 'InverseTempoFunction'.  TODO think of better names
data Stop =
    -- | Stop emitting ScoreTime as soon as the events on the block end.
    -- This is used by the play monitor, since I want it to stop as soon as
    -- the score is "over" visually.
    StopAtEnd
    -- | Keep emitting score time for all blocks.  This is used to map from
    -- RealTime to ScoreTime for a particular block, regardless of the notes on
    -- it.  E.g. Msg.ImProgress uses this because synthesis continues as long
    -- as the notes ring.
    | NoStop
    deriving (Stop -> Stop -> Bool
(Stop -> Stop -> Bool) -> (Stop -> Stop -> Bool) -> Eq Stop
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stop -> Stop -> Bool
$c/= :: Stop -> Stop -> Bool
== :: Stop -> Stop -> Bool
$c== :: Stop -> Stop -> Bool
Eq, Int -> Stop -> ShowS
[Stop] -> ShowS
Stop -> String
(Int -> Stop -> ShowS)
-> (Stop -> String) -> ([Stop] -> ShowS) -> Show Stop
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stop] -> ShowS
$cshowList :: [Stop] -> ShowS
show :: Stop -> String
$cshow :: Stop -> String
showsPrec :: Int -> Stop -> ShowS
$cshowsPrec :: Int -> Stop -> ShowS
Show)