async-timer (empty) → 0.1.4.0
raw patch · 8 files changed
+316/−0 lines, 8 filesdep +HUnitdep +async-timerdep +basesetup-changed
Dependencies added: HUnit, async-timer, base, containers, criterion, lifted-async, lifted-base, monad-control, safe-exceptions, test-framework, test-framework-hunit, transformers-base
Files
- LICENSE +30/−0
- README.md +19/−0
- Setup.hs +2/−0
- async-timer.cabal +50/−0
- src/Control/Concurrent/Async/Timer.hs +30/−0
- src/Control/Concurrent/Async/Timer/Internal.hs +77/−0
- src/Control/Concurrent/Async/Timer/Unsafe.hs +39/−0
- test/Spec.hs +69/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Moritz Schulte (c) 2016-2017++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 Author name here 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.
+ README.md view
@@ -0,0 +1,19 @@+# async-timer [](https://hackage.haskell.org/package/async-timer) [](https://www.stackage.org/package/async-timer) [](https://travis-ci.org/mtesseract/async-timer)++### About++This is a lightweight package built on top of the async package+providing easy to use periodic timers. This can be used for executing+IO actions periodically.++### Example:++```haskell+ let conf = defaultTimerConf & timerConfSetInitDelay 500 -- 500 ms+ & timerConfSetInterval 1000 -- 1 s+ + withAsyncTimer conf $ \ timer -> do+ forM_ [1..10] $ \_ -> do+ timerWait timer+ putStrLn "Tick"+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ async-timer.cabal view
@@ -0,0 +1,50 @@+name: async-timer+version: 0.1.4.0+synopsis: Provides API for timer based execution of IO actions+description: This is a lightweight package built on top of the async package+ providing easy to use periodic timers. This can be used for executing+ IO actions periodically.+homepage: https://github.com/mtesseract/async-timer+license: BSD3+license-file: LICENSE+author: Moritz Schulte+maintainer: mtesseract@silverratio.net+copyright: (c) 2016-2017 Moritz Schulte+category: Concurrency+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Control.Concurrent.Async.Timer+ , Control.Concurrent.Async.Timer.Unsafe+ other-modules: Control.Concurrent.Async.Timer.Internal+ build-depends: base >= 4.9.1.0 && < 5+ , lifted-base >= 0.2.3.11 && < 0.3+ , lifted-async >= 0.9.1.1 && < 0.10+ , monad-control >= 1.0.1.0 && < 1.1+ , safe-exceptions >= 0.1.5.0 && < 0.2+ , transformers-base >= 0.4.4 && < 0.5+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-type-defaults++test-suite async-timer-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , lifted-async+ , async-timer+ , HUnit+ , test-framework+ , test-framework-hunit+ , containers+ , criterion+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ default-extensions: OverloadedStrings++source-repository head+ type: git+ location: https://github.com/mtesseract/async-timer
+ src/Control/Concurrent/Async/Timer.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Control.Concurrent.Async.Timer+ ( Timer+ , defaultTimerConf+ , timerConfSetInitDelay+ , timerConfSetInterval+ , withAsyncTimer+ , timerWait+ ) where++import Control.Concurrent.Async.Lifted.Safe+import Control.Concurrent.Async.Timer.Internal+import qualified Control.Concurrent.Async.Timer.Unsafe as Unsafe+import Control.Exception.Safe+import Control.Monad.Trans.Control++-- | Spawn a timer thread based on the provided timer configuration+-- and then run the provided IO action, which receives the new timer+-- as an argument and call 'timerWait' on it for synchronization. When+-- the provided IO action has terminated, the timer thread will be+-- terminated also.+--+-- This functions requires the contraint @'Forall' ('Pure' m)@, which+-- means that the monad 'm' needs to satisfy @'StM' m a ~ a@ for all+-- 'a'.+withAsyncTimer :: (MonadBaseControl IO m, MonadMask m, Forall (Pure m))+ => TimerConf -> (Timer -> m b) -> m b+withAsyncTimer = Unsafe.withAsyncTimer
+ src/Control/Concurrent/Async/Timer/Internal.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Control.Concurrent.Async.Timer.Internal+ ( Timer(..)+ , TimerConf(..)+ , TimerException(..)+ , defaultTimerConf+ , timerThread+ , timerConfSetInitDelay+ , timerConfSetInterval+ , timerWait+ ) where++import Control.Concurrent.Lifted+import Control.Exception.Safe+import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans.Control++-- | Timer specific exception; only used for a graceful termination+-- mechanism for timer threads.+data TimerException = TimerEnd deriving (Typeable, Show)++instance Exception TimerException++-- | This is the type of timer handle, which will be provided to the+-- IO action to be executed within 'withAsyncTimer'. The user can use+-- 'timerWait' on this timer to delay execution until the next timer+-- synchronization event.+newtype Timer = Timer { timerMVar :: MVar () }++-- | Type of a timer configuration.+data TimerConf = TimerConf { _timerConfInitDelay :: Int+ , _timerConfInterval :: Int }++-- | This exception handler acts on exceptions of type+-- 'TimerException'. What it essentially does is providing a mechanism+-- for graceful termination of timer threads by simply ignoring the+-- TimerEnd exception.+timerHandler :: Monad m => Handler m ()+timerHandler = Handler $ \case+ TimerEnd -> return ()++-- | Sleep 'dt' milliseconds.+millisleep :: MonadBase IO m => Int -> m ()+millisleep dt = threadDelay (fromIntegral dt * 10 ^ 3)++-- | Default timer configuration specifies no initial delay and an+-- interval delay of 1s.+defaultTimerConf :: TimerConf+defaultTimerConf = TimerConf { _timerConfInitDelay = 0+ , _timerConfInterval = 1000 }++-- | Set the initial delay in the provided timer configuration.+timerConfSetInitDelay :: Int -> TimerConf -> TimerConf+timerConfSetInitDelay n conf = conf { _timerConfInitDelay = n }++-- | Set the interval delay in the provided timer configuration.+timerConfSetInterval :: Int -> TimerConf -> TimerConf+timerConfSetInterval n conf = conf { _timerConfInterval = n }++-- | IO action to be executed within in a timer thread.+timerThread :: (MonadBaseControl IO m, MonadCatch m) => Int -> Int -> MVar () -> m ()+timerThread initDelay intervalDelay syncMVar =+ catches (timerLoop initDelay intervalDelay syncMVar) [timerHandler]++-- | Timer loop to be executed within in a timer thread.+timerLoop :: (MonadBaseControl IO m) => Int -> Int -> MVar () -> m ()+timerLoop initDelay intervalDelay syncMVar = do+ millisleep initDelay+ forever $ putMVar syncMVar () >> millisleep intervalDelay++-- | Wait for the next synchronization event on the givem timer.+timerWait :: MonadBaseControl IO m => Timer -> m ()+timerWait = void . takeMVar . timerMVar
+ src/Control/Concurrent/Async/Timer/Unsafe.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Concurrent.Async.Timer.Unsafe+ ( Timer+ , defaultTimerConf+ , timerConfSetInitDelay+ , timerConfSetInterval+ , withAsyncTimer+ , timerWait+ ) where++import Control.Concurrent.Async.Lifted+import Control.Concurrent.Async.Timer.Internal+import Control.Concurrent.Lifted+import Control.Exception.Safe+import Control.Monad.Trans.Control++-- | Spawn a timer thread based on the provided timer configuration+-- and then run the provided IO action, which receives the new timer+-- as an argument and call 'timerWait' on it for synchronization. When+-- the provided IO action has terminated, the timer thread will be+-- terminated also.+withAsyncTimer :: (MonadBaseControl IO m, MonadMask m)+ => TimerConf -> (Timer -> m b) -> m b+withAsyncTimer conf io = do+ -- This MVar will be our synchronization mechanism.+ mVar <- newEmptyMVar+ let timer = Timer { timerMVar = mVar }+ initDelay = _timerConfInitDelay conf+ intervalDelay = _timerConfInterval conf+ withAsync (timerThread initDelay intervalDelay mVar) $ \asyncHandle -> do+ -- This guarantees that we will be informed right away if our+ -- timer thread disappears, for example because of an async+ -- exception:+ link asyncHandle+ -- This guarantees that we will throw the TimerEnd exception to+ -- the timer thread after the provided IO action has ended+ -- (w/ or w/o an exception):+ io timer `finally` cancelWith asyncHandle TimerEnd
+ test/Spec.hs view
@@ -0,0 +1,69 @@+module Main where++import Control.Concurrent+import Control.Concurrent.Async.Timer+import Control.Exception+import Control.Monad+import Criterion.Measurement+import Data.Function ((&))+import Data.IORef+import Data.Typeable+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++data MyException = MyException+ deriving (Show, Typeable)++instance Exception MyException++main :: IO ()+main = do+ cap <- getNumCapabilities+ putStrLn ""+ putStrLn $ "Cap = " ++ show cap+ defaultMain tests++tests :: [Test.Framework.Test]+tests =+ [ testGroup "1st Test Group"+ [ testCase "1st Test" test1 ]+ ]++test1 :: IO ()+test1 = do+ let conf = defaultTimerConf & timerConfSetInitDelay 0+ & timerConfSetInterval 1000 -- ms+ noOfTicks = 5++ counter <- newIORef 0+ times <- newIORef []++ withAsyncTimer conf $ \ timer ->+ forM_ [1..noOfTicks] $ \_ -> do+ timerWait timer+ void $ forkIO $ myAction counter times++ threadDelay (5 * 10^5)+ n <- readIORef counter+ n @?= noOfTicks++ ts <- readIORef times+ let deltas = case ts of+ [] -> []+ _ : tsTail -> zipWith (-) ts tsTail++ avgDiff = sum (map (subtract 1) deltas) / fromIntegral (length deltas)+ forM_ deltas (\ dt -> putStrLn $ "dt = " ++ show dt)+ putStrLn $ "average dt = " ++ show avgDiff+ return ()++ where myAction :: IORef Int -> IORef [Double] -> IO ()+ myAction counter times = do+ t <- getTime+ n <- readIORef counter+ let n' = n + 1+ writeIORef counter n'+ modifyIORef times (t :)+ putStrLn $ "Tick no. " ++ show n' ++ " (t = " ++ show t ++ ")"+ threadDelay 500000