metronome-0.1: System/Metronome.hs
{-# LANGUAGE TemplateHaskell, FlexibleContexts #-}
-- |
-- Module : System.Metronome
-- Copyright : (c) Paolo Veronelli 2012
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : paolo.veronelli@gmail.com
-- Stability : unstable
-- Portability : not portable (requires STM)
--
-- /Synchronized execution of sequences of actions, controlled in STM/
--
-- All data structures are made accessible via "Data.Lens" abstraction.
--
-- Actions to be executed are of type 'Action' = STM (IO ()). At each tick, the scheduled actions are ordered by priority,
-- binded as STM actions ignoring the retrying ones. The results, being IO actions are executed in that order.
--
-- Every 'Track' and 'Metronome' lives in its own thread and can be stopped or killed as such, setting a flag in its state.
--
-- Track and metronome state are exposed in TVar value to be modified at will. The only closed and inaccessible value is the synchronizing channel,
-- written by the metronome and waited by tracks.
-- The 'TrackForker' returned by a metronome function is closing this channel and it's the only way to fork a track.
--
-- See "System.Metronome.Practical" for an simple wrapper around this module.
--
module System.Metronome (
-- * Data structures
Track (..)
, Thread (..)
, Metronome (..)
-- * Lenses
, sync
, frequency
, actions
, priority
, muted
, running
, alive
, core
, ticks
, schedule
-- * Synonyms
, Control
, Priority
, Frequency
, Ticks
, Action
, MTime
, TrackForker
-- * API
, metronome
) where
import Sound.OpenSoundControl (utcr, sleepThreadUntil)
import Control.Concurrent.STM (STM, TVar, TChan , atomically, newBroadcastTChan, orElse, dupTChan)
import Control.Concurrent (forkIO, myThreadId, killThread)
import Control.Monad (join, liftM, forever, when)
import Data.Ord (comparing)
import Data.List (sortBy)
import Data.Lens.Template (makeLens)
import Data.Lens.Lazy (modL)
import Control.Concurrent.STMOrIO
-- | Track effect interface. Write in STM the collective and spit out the IO action to be executed when all STMs for this tick are done or retried
type Action = STM (IO ())
-- | Priority values between tracks under the same metronome.
type Priority = Double
-- | Number of metronome ticks between two track ticks
type Frequency = Integer
-- | Number of elapsed ticks
type Ticks = Integer
-- execute actions, from STM to IO ignoring retriers
execute :: [Action] -> IO ()
execute = join . liftM sequence_ . atomically . mapM (`orElse` return (return ()))
-- | State of a track.
data Track = Track {
-- | the number of ticks elapsed from the track fork
_sync :: Ticks,
-- | calling frequency relative to metronome ticks frequency
_frequency :: Frequency,
-- | the actions left to be run
_actions :: [Action],
-- | priority of this track among its peers
_priority :: Priority,
-- | muted flag, when True, actions are not scheduled, just skipped
_muted :: Bool
}
$( makeLens ''Track)
-- | supporting values with 'running' and 'alive' flag
data Thread a = Thread {
-- | stopped or running flag
_running :: Bool,
-- | set to false to require kill thread
_alive :: Bool,
-- | core data
_core :: a
}
$( makeLens ''Thread)
-- | A Thread value cell in STM
type Control a = TVar (Thread a)
-- | Time, in seconds
type MTime = Double
-- | State of a metronome
data Metronome = Metronome {
_ticks :: [MTime], -- ^ next ticking times
_schedule :: [(Priority, Action)] -- ^ actions scheduled for the tick to come
}
$( makeLens ''Metronome)
-- | The action to fork a new track from a track state.
type TrackForker = Control Track -> IO ()
-- helper to modify an 'Thread' fulfilling 'running' and 'alive' flags.
runThread :: (Monad m, RW m TVar) => Control a -> m () -> (a -> m a) -> m ()
runThread ko kill modify = do
-- read the object
Thread r al x <- rd ko
if not al then kill
else when r $ do
-- modify as requested
x' <- modify x
-- write the object
md ko $ modL core $ const x'
-- forkIO with kill thread
forkIO' :: (IO () -> IO ()) -> IO ()
forkIO' f = forkIO (myThreadId >>= f . killThread) >> return ()
-- fork a track based on a metronome and the track initial state
forkTrack :: TChan () -> Control Metronome -> Control Track -> IO ()
forkTrack kc tm tc = forkIO' $ \kill -> do
-- make new metronome listener
kn <- atomically $ dupTChan kc
forever $ do
rd kn -- wait for a tick
runThread tc kill $ \(Track n m fss z g) -> atomically $ do
Thread ru li (Metronome ts ss) <- rd tm
-- check if it's time to fire
let (ss',fs') = if null fss then (ss,fss)
else let f:fs'' = fss in if n `mod` m == 0
-- fire if it's not muted
then if not g then ((z,f):ss,fs'')
-- else don't consume
else (ss,fs'')
else (ss,fss)
wr tm $ Thread ru li (Metronome ts ss')
-- the new Track with one more tick elapsed and the actions left to run
return $ Track (n + 1) m fs' z g
-- | Fork a metronome from its initial state
metronome :: Control Metronome -- ^ initial state
-> IO TrackForker
metronome km = do
kc <- atomically newBroadcastTChan -- non leaking channel
forkIO' $ \kill -> forever . runThread km kill $ \m@(Metronome ts _) -> do
t <- utcr -- time now
-- throw away the past ticking time
case dropWhile (< t) ts of
[] -> return m -- no ticks left to wait
t':ts' -> do
-- sleep until next
sleepThreadUntil t'
-- execute scheduled actions after ordering by priority
Metronome _ rs <- _core `liftM` rd km
execute . map snd . sortBy (comparing fst) $ rs
-- broadcast tick for all track to schedule next actions
wr kc ()
-- the new Metronome with times in future and no actions scheduled
return $ Metronome ts' []
return $ forkTrack kc km