diff --git a/Control/Concurrent/STMOrIO.hs b/Control/Concurrent/STMOrIO.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STMOrIO.hs @@ -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)) + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Metronome.hs b/System/Metronome.hs new file mode 100644 --- /dev/null +++ b/System/Metronome.hs @@ -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 + + + + + + + + + + diff --git a/System/Metronome/Practical.hs b/System/Metronome/Practical.hs new file mode 100644 --- /dev/null +++ b/System/Metronome/Practical.hs @@ -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 + + + + + diff --git a/metronome.cabal b/metronome.cabal new file mode 100644 --- /dev/null +++ b/metronome.cabal @@ -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 +