metronome (empty) → 0.1
raw patch · 6 files changed
+463/−0 lines, 6 filesdep +basedep +data-lensdep +data-lens-templatesetup-changed
Dependencies added: base, data-lens, data-lens-template, hosc, stm
Files
- Control/Concurrent/STMOrIO.hs +58/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- System/Metronome.hs +196/−0
- System/Metronome/Practical.hs +145/−0
- metronome.cabal +32/−0
+ Control/Concurrent/STMOrIO.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}++-- | +-- Module : Control.Concurrent.STMOrIO+-- Copyright : (c) Paolo Veronelli 2012+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : paolo.veronelli@gmail.com+-- Stability : unstable+-- Portability : not portable (requires STM)+--+-- Unifying functions of TVar's and TChans in STM and IO via atomically.+--+module Control.Concurrent.STMOrIO where++import Control.Concurrent.STM++-- | uniforming class for STM or IO+class (Functor m, Monad m) => STMOrIO m where+ stmorio :: STM a -> m a+instance STMOrIO IO where+ stmorio = atomically+instance STMOrIO STM where+ stmorio = id++-- | class to uniform reading and writing +class RW m z where+ -- | read a z+ rd :: z a -> m a + -- | modify a z+ wr :: z a -> a -> m ()++-- | modify a cell z under STM or IO+md :: (Monad m, RW m z) => z a -> (a -> a) -> m ()+md x f = rd x >>= \y -> wr x (f y)++instance STMOrIO t => RW t TVar where+ rd = stmorio . readTVar+ wr x = stmorio . writeTVar x++instance STMOrIO t => RW t TChan where+ rd = stmorio . readTChan+ wr x = stmorio . writeTChan x+++-- | new TVar +var :: STMOrIO m + => a -- ^ initial value+ -> m (TVar a)+var = stmorio . newTVar++-- | new TChan+chan :: forall m a . STMOrIO m + => a -- ^ type proxy value+ -> m (TChan a)+chan _ = stmorio (newTChan :: STM (TChan a))++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, paolo veronelli++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of paolo veronelli nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Metronome.hs view
@@ -0,0 +1,196 @@+{-# 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++ +++++ + + +
+ System/Metronome/Practical.hs view
@@ -0,0 +1,145 @@+-- | +-- Module : System.Metronome.Practical+-- Copyright : (c) Paolo Veronelli 2012+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : paolo.veronelli@gmail.com+-- Stability : unstable+-- Portability : not portable (requires STM)+--+-- A wrapper module around "System.Metronome" with easy functions.+--+--+-- In this snippet we run a metronome and attach 4 tracks to it. +--+-- First track ticks every 2 metronome ticks printing \".\" 5 times. +--+-- Second track ticks at each metronome tick. Forever it reads a string from a variable, +-- it checks first track for actions finished, and push other 5 actions on the first, each printing the string read.+--+-- Third track ticks every 14 metronome ticks and forever modifies the string in the variable.+--+-- Fourth track ticks every 100 metronome ticks , it does nothing on first action , kill all tracks , including itself and the metronome,+-- and wake up main thread on the second.+-- +-- > {-# LANGUAGE DoRec #-}+-- > +-- > import System.IO+-- > import System.Metronome.Practical+-- > import Control.Concurrent.STMOrIO+-- > import Control.Monad+-- > +-- > main = do+-- > hSetBuffering stdout NoBuffering+-- > (m,f) <- dummyMetronome 0.1+-- > c <- dummyTrack f 2 0 $ replicate 5 $ return $ putStr "."+-- > v <- var "!" +-- > c2 <- dummyTrack f 1 0 . repeat . noIO $ do+-- > as <- getActions c+-- > vl <- rd v+-- > when (null as) . setActions c . replicate 5 . return $ putStr vl+-- > c3 <- dummyTrack f 14 0 . repeat . noIO . md v $ map succ+-- > end <- chan ()+-- > rec {c4 <- dummyTrack f 100 0 . map noIO $ [return (), mapM_ kill [c,c2,c3,c4] >> kill m >> wr end ()]}+-- > mapM_ run [c,c2,c3,c4]+-- > rd end+-- > hSetBuffering stdout LineBuffering +--+module System.Metronome.Practical (+ -- * Thread + kill+ , stop+ , run+ , modRunning+ -- * Metronome+ , setTicks+ , modScheduled+ -- * Track+ , modPhase+ , setFrequency+ , getActions+ , setActions+ , setPriority+ , modMute+ -- * Dummy+ , dummyMetronome+ , dummyTrack+ -- * Practical+ , noIO + ) where++import Control.Concurrent.STMOrIO+import Control.Concurrent.STM+import Sound.OpenSoundControl+import System.Metronome+import Data.Lens.Lazy++-- | no IO as result of the STM action+noIO :: STM () -> STM (IO ())+noIO f = f >> return (return ())++-- | kill a thread+kill :: STMOrIO m => Control a -> m ()+kill x = md x $ alive `setL` False++-- | stop a thread+stop :: STMOrIO m => Control a -> m ()+stop x = md x $ running `setL` False++-- | run a thread+run :: STMOrIO m => Control a -> m ()+run x = md x $ running `setL` True++-- | invert the running flag of a thread +modRunning :: STMOrIO m => Control a -> m ()+modRunning x = md x $ running `modL` not++-- | set the next ticking times for a metronome+setTicks :: STMOrIO m => Control Metronome -> [MTime] -> m ()+setTicks x = md x . modL core . setL ticks++-- | change the actions scheduled for the next metronome tick+modScheduled :: STMOrIO m => Control Metronome -> ([(Priority,Action)] -> [(Priority, Action)]) -> m ()+modScheduled x = md x . modL core . modL schedule+ +-- | modify the ticks count from track start, shifting the next ticks relative to metronome ticks+modPhase :: STMOrIO m => Control Track -> (Ticks -> Ticks) -> m ()+modPhase x = md x . modL core . modL sync++-- | set the track frequency+setFrequency :: STMOrIO m => Control Track -> Frequency -> m ()+setFrequency x = md x . modL core . setL frequency++-- | set the track actions+setActions :: STMOrIO m => Control Track -> [Action] -> m ()+setActions x = md x . modL core . setL actions++-- | read the remaining actions of a track+getActions :: STMOrIO m => Control Track -> m [Action]+getActions x = (getL actions . getL core) `fmap` rd x++-- | set a track priority+setPriority :: STMOrIO m => Control Track -> Priority -> m ()+setPriority x = md x . modL core . setL priority++-- | mute / unmute a track+modMute :: STMOrIO m => Control Track -> m ()+modMute x = md x . modL core $ muted `modL` not++-- | create and fork a running metronome.+dummyMetronome :: MTime -- ^ time between ticks, in seconds+ -> IO (Control Metronome, TrackForker) -- ^ metronome control structure and a function to fork tracks+dummyMetronome d = utcr >>= \t0 -> var (Thread True True $ Metronome [t0, t0 + d ..] []) >>= \m -> metronome m >>= \f -> return (m,f)++-- | create and fork a stopped track by a metronome+dummyTrack :: TrackForker -- ^ a track forking action from a metronome fork+ -> Frequency -- ^ ratio of track ticks and metronome ticks+ -> Priority -- ^ priority among the track peers+ -> [Action] -- ^ actions to be executed, each on a separate track tick+ -> IO (Control Track) -- ^ track control structure+dummyTrack tf fr pr as = var (Thread False True $ Track 0 fr as pr False) >>= \t -> tf t >> return t+++++
+ metronome.cabal view
@@ -0,0 +1,32 @@+Name: metronome+Version: 0.1+Synopsis: Time Synchronized execution.+Description: Metronome and tracks, useful to execute IO actions at regular intervals. State exposed via STM.+License: BSD3+License-file: LICENSE+Category: System+Copyright: (c) Paolo Veonelli, 2012+Author: Paolo Veronelli+Maintainer: paolo.veronelli@gmail.com+Stability: Experimental+Homepage: +Tested-With: GHC == 7.4.2+Build-Type: Simple+Cabal-Version: >= 1.8+++Library+ Build-Depends: base == 4.*,+ hosc >= 0.11,+ stm >= 2.4,+ data-lens,+ data-lens-template++ GHC-Options: -Wall -fwarn-tabs+ Exposed-modules: System.Metronome, Control.Concurrent.STMOrIO, System.Metronome.Practical+ Other-modules: ++source-repository head+ type: git+ location: git://github.com/paolino/metronome.git+