module Perform.Transport (
Status(..), Info(..)
, PlayControl(..), play_control
, stop_player, poll_stop_player
, ActivePlayers, active_players
, player_started, player_stopped
, poll_player_stopped, wait_player_stopped
, 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
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 Info = Info {
Info -> Status -> IO ()
info_send_status :: Status -> IO ()
, Info -> Message -> IO ()
info_midi_writer :: Interface.Message -> IO ()
, Info -> IO ()
info_midi_abort :: IO ()
, Info -> IO RealTime
info_get_current_time :: IO RealTime
, Info -> MVar State
info_state :: MVar.MVar Ui.State
}
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
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
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)
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)
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
type TempoFunction = BlockId -> TrackId -> ScoreTime -> [RealTime]
type ClosestWarpFunction = BlockId -> TrackId -> RealTime -> Warp.Warp
type InverseTempoFunction =
Stop -> RealTime -> [(BlockId, [(TrackId, ScoreTime)])]
data Stop =
StopAtEnd
| 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)