diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Petr Pilař + +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 Petr Pilař 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md 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/src/Control/Concurrent/Timer.hs b/src/Control/Concurrent/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Timer.hs @@ -0,0 +1,129 @@ +module Control.Concurrent.Timer +( Timer +, TimerIO + +, oneShotTimer +, oneShotRestart + +, repeatedTimer +, repeatedRestart + +, newTimer +, stopTimer +) where + +------------------------------------------------------------------------------ +import Control.Applicative +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Concurrent.MVar (newMVar, tryTakeMVar, putMVar, modifyMVar_) +import Control.Concurrent.Suspend (Delay, suspend) +import Control.Monad +------------------------------------------------------------------------------ +import Control.Concurrent.Timer.Types (Timer(..)) +------------------------------------------------------------------------------ + +-- | Attempts to restart (or start) a timer making it a one shot timer. +-- +-- Returns True if the restrat was successful, +-- otherwise (e.g. other thread is attempting to restart the timer) returns False. +oneShotRestart :: TimerIO + -> IO Bool +oneShotRestart (Timer action delay threadID) = do + mtid <- tryTakeMVar threadID + case mtid of + Just (Just tid) -> do + killThread tid + ntid <- Just <$> oneShotAction delay action + putMVar threadID ntid + return True + Just (Nothing) -> do + ntid <- Just <$> oneShotAction delay action + putMVar threadID ntid + return True + Nothing -> return False +{-# INLINEABLE oneShotRestart #-} + +-- | Attempts to restart (or start) a timer making it a repeated timer. +-- +-- Returns True if the restrat was successful, +-- otherwise (e.g. other thread is attempting to restart the timer) returns False. +repeatedRestart :: TimerIO + -> IO Bool +repeatedRestart (Timer action delay threadID) = do + mtid <- tryTakeMVar threadID + case mtid of + Just (Just tid) -> do + killThread tid + ntid <- Just <$> repeatedAction delay action + putMVar threadID ntid + return True + Just (Nothing) -> do + ntid <- Just <$> repeatedAction delay action + putMVar threadID ntid + return True + Nothing -> return False +{-# INLINEABLE repeatedRestart #-} + +-- | Executes the the given action once after the given delay elapsed, no sooner, maybe later. +oneShotTimer :: Delay -- ^ The (minimal) time until the execution in microseconds. + -> IO () -- ^ The action to be executed. + -> IO (TimerIO) +oneShotTimer d action = do + tid <- oneShotAction d action >>= newMVar . Just + return Timer { timerAction = action + , timerDelay = d + , timerThreadID = tid + } +{-# INLINEABLE oneShotTimer #-} + +-- | Executes the the given action repeatedly with at least the given delay between executions. +repeatedTimer :: Delay -- ^ The (minimal) delay between executions. + -> IO () -- ^ The action to be executed. + -> IO (TimerIO) +repeatedTimer d action = do + tid <- repeatedAction d action >>= newMVar . Just + return Timer { timerAction = action + , timerDelay = d + , timerThreadID = tid + } +{-# INLINEABLE repeatedTimer #-} + +-- | This function is blocking. It waits until it can stop the timer +-- (until there is a value in the threadID MVar), then it kill the thread. +stopTimer :: TimerIO + -> IO () +stopTimer (Timer _ _ threadID) = modifyMVar_ threadID $ + maybe (return Nothing) + (\tid -> killThread tid >> return Nothing) + +-- | Creates a new timer. This does not start the timer. +newTimer :: Delay -- ^ The (minimal) delay between executions. + -> IO () -- ^ The action to be executed. + -> IO (TimerIO) +newTimer d action = Timer action d <$> newMVar Nothing +{-# INLINE newTimer #-} + +------------------------------------------------------------------------------ +-- | Utility + +type TimerIO = Timer IO + +-- | Forks a new thread that runs the supplied action +-- (at least) after the given delay. +oneShotAction :: Delay + -> IO () + -> IO ThreadId +oneShotAction d action = fork (suspend d >> action) +{-# INLINE oneShotAction #-} + +-- | Forks a new thread that repeats the supplied action +-- with (at least) the given delay between each execution. +repeatedAction :: Delay + -> IO () + -> IO ThreadId +repeatedAction d action = fork (forever $ suspend d >> action) +{-# INLINE repeatedAction #-} + +fork :: IO () -> IO ThreadId +fork = forkIO +{-# INLINE fork #-} diff --git a/src/Control/Concurrent/Timer/Lifted.hs b/src/Control/Concurrent/Timer/Lifted.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Timer/Lifted.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Control.Concurrent.Timer.Lifted +( Timer +, TimerIO + +, oneShotTimer +, oneShotRestart + +, repeatedTimer +, repeatedRestart + +, newTimer +, stopTimer +) where + +------------------------------------------------------------------------------ +import Control.Applicative +import Control.Concurrent.Lifted (ThreadId, fork, killThread) +import Control.Concurrent.MVar.Lifted (newMVar, tryTakeMVar, putMVar, modifyMVar_) +import Control.Concurrent.Suspend.Lifted (Delay, suspend) +import Control.Monad +import Control.Monad.Base (MonadBase) +import Control.Monad.Trans.Control (MonadBaseControl) +------------------------------------------------------------------------------ +import Control.Concurrent.Timer.Types (Timer(..)) +------------------------------------------------------------------------------ + +-- | Attempts to restart (or start) a timer making it a one shot timer. +-- +-- Returns True if the restrat was successful, +-- otherwise (e.g. other thread is attempting to restart the timer) returns False. +oneShotRestart :: MonadBaseControl IO m + => Timer m + -> m Bool +oneShotRestart (Timer action delay threadID) = do + mtid <- tryTakeMVar threadID + case mtid of + Just (Just tid) -> do + killThread tid + ntid <- Just <$> oneShotAction delay action + putMVar threadID ntid + return True + Just (Nothing) -> do + ntid <- Just <$> oneShotAction delay action + putMVar threadID ntid + return True + Nothing -> return False +{-# INLINEABLE oneShotRestart #-} + +-- | Attempts to restart (or start) a timer making it a repeated timer. +-- +-- Returns True if the restrat was successful, +-- otherwise (e.g. other thread is attempting to restart the timer) returns False. +repeatedRestart :: MonadBaseControl IO m + => Timer m + -> m Bool +repeatedRestart (Timer action delay threadID) = do + mtid <- tryTakeMVar threadID + case mtid of + Just (Just tid) -> do + killThread tid + ntid <- Just <$> repeatedAction delay action + putMVar threadID ntid + return True + Just (Nothing) -> do + ntid <- Just <$> repeatedAction delay action + putMVar threadID ntid + return True + Nothing -> return False +{-# INLINEABLE repeatedRestart #-} + +-- | Executes the the given action once after the given delay elapsed, no sooner, maybe later. +oneShotTimer :: MonadBaseControl IO m + => Delay -- ^ The (minimal) time until the execution in microseconds. + -> m () -- ^ The action to be executed. + -> m (Timer m) +oneShotTimer d action = do + tid <- oneShotAction d action >>= newMVar . Just + return Timer { timerAction = action + , timerDelay = d + , timerThreadID = tid + } +{-# INLINEABLE oneShotTimer #-} + +-- | Executes the the given action repeatedly with at least the given delay between executions. +repeatedTimer :: MonadBaseControl IO m + => Delay -- ^ The (minimal) delay between executions. + -> m () -- ^ The action to be executed. + -> m (Timer m) +repeatedTimer d action = do + tid <- repeatedAction d action >>= newMVar . Just + return Timer { timerAction = action + , timerDelay = d + , timerThreadID = tid + } +{-# INLINEABLE repeatedTimer #-} + +-- | This function is blocking. It waits until it can stop the timer +-- (until there is a value in the threadID MVar), then it kill the thread. +stopTimer :: MonadBaseControl IO m + => Timer m + -> m () +stopTimer (Timer _ _ threadID) = modifyMVar_ threadID $ + maybe (return Nothing) + (\tid -> killThread tid >> return Nothing) + +-- | Creates a new timer. This does not start the timer. +newTimer :: MonadBase IO m + => Delay -- ^ The (minimal) delay between executions. + -> m () -- ^ The action to be executed. + -> m (Timer m) +newTimer d action = Timer action d <$> newMVar Nothing +{-# INLINE newTimer #-} + +------------------------------------------------------------------------------ +-- | Utility + +type TimerIO = Timer IO + +-- | Forks a new thread that runs the supplied action +-- (at least) after the given delay. +oneShotAction :: MonadBaseControl IO m + => Delay + -> m () + -> m ThreadId +oneShotAction d action = fork (suspend d >> action) +{-# INLINE oneShotAction #-} + +-- | Forks a new thread that repeats the supplied action +-- with (at least) the given delay between each execution. +repeatedAction :: MonadBaseControl IO m + => Delay + -> m () + -> m ThreadId +repeatedAction d action = fork (forever $ suspend d >> action) +{-# INLINE repeatedAction #-} diff --git a/timers.cabal b/timers.cabal new file mode 100644 --- /dev/null +++ b/timers.cabal @@ -0,0 +1,36 @@ +name: timers +version: 0.1.0.0 +synopsis: Simple package that implements timers. +description: Simple package that implements timers. Both "one-shot" and "repeating" timers are implemented. +license: BSD3 +license-file: LICENSE +author: Petr Pilař +maintainer: Petr Pilař +copyright: Petr Pilař 2012 +category: Concurrency +stability: Experimental +build-type: Simple +cabal-version: >=1.8 + +extra-source-files: + LICENSE + , README.md + +library + exposed-modules: + Control.Concurrent.Timer + , Control.Concurrent.Timer.Lifted + + build-depends: + base == 4.5.* + , lifted-base == 0.1.* + , monad-control == 0.3.* + , transformers-base == 0.4.* + , suspend == 0.1.* + + hs-source-dirs: src + ghc-options: -Wall -fwarn-unused-imports + +source-repository head + type: git + location: git://github.com/Palmik/timers.git