Merge pull request mtesseract#2 from mtesseract/ms-refactoring-and-timer-thread-link

Cleaned up and refactored code base

Author: mtesseract

LICENSE

@@ -1,4 +1,4 @@
-Copyright Moritz Schulte (c) 2016, 2017
+Copyright Moritz Schulte (c) 2016-2017
 
 All rights reserved.
 

async-timer.cabal

@@ -1,5 +1,5 @@
 name:                async-timer
-version:             0.1.3.1
+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
@@ -9,7 +9,7 @@ license:             BSD3
 license-file:        LICENSE
 author:              Moritz Schulte
 maintainer:          [email protected]
-copyright:           2016, 2017 Moritz Schulte
+copyright:           (c) 2016-2017 Moritz Schulte
 category:            Concurrency
 build-type:          Simple
 extra-source-files:  README.md
@@ -20,10 +20,12 @@ library
   exposed-modules:     Control.Concurrent.Async.Timer
                      , Control.Concurrent.Async.Timer.Unsafe
   other-modules:       Control.Concurrent.Async.Timer.Internal
-  build-depends:       base >= 4.7 && < 5
+  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
 

src/Control/Concurrent/Async/Timer.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes            #-}
 
 module Control.Concurrent.Async.Timer
   ( Timer
@@ -13,21 +12,19 @@ module Control.Concurrent.Async.Timer
 
 import           Control.Concurrent.Async.Lifted.Safe
 import           Control.Concurrent.Async.Timer.Internal
-import           Control.Concurrent.Lifted
-import           Control.Monad
+import qualified Control.Concurrent.Async.Timer.Unsafe   as Unsafe
+import           Control.Exception.Safe
 import           Control.Monad.Trans.Control
 
-withAsyncTimer :: forall m b. (MonadBaseControl IO m, Forall (Pure m))
+-- | 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 conf io = do
-  mVar <- newEmptyMVar
-  let timer        = Timer { timerMVar = mVar }
-      timerTrigger = void $ tryPutMVar mVar ()
-      initDelay'   = toMicroseconds $ _timerConfInitDelay conf
-      interval'    = toMicroseconds $ _timerConfInterval  conf
-      timerThread  = timerLoop (threadDelay initDelay')
-                               (threadDelay interval')
-                               timerTrigger
-  withAsync timerThread $ const (io timer)
-
-  where toMicroseconds x = x * (10 ^ 3)
+withAsyncTimer = Unsafe.withAsyncTimer

src/Control/Concurrent/Async/Timer/Internal.hs

@@ -1,36 +1,77 @@
 {-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 
-module Control.Concurrent.Async.Timer.Internal where
+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
-import           Data.Int
 
--- | Sleep 'dt' milliseconds.
-millisleep :: Int64 -> IO ()
-millisleep dt = threadDelay (fromIntegral dt * 10 ^ 3)
+-- | 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 }
 
-newtype Timer = Timer { timerMVar :: MVar () }
+-- | 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]
 
-timerLoop :: MonadBaseControl IO m => m () -> m () -> m () -> m ()
-timerLoop initDelay intervalDelay timerTrigger = do
-  initDelay
-  forever $ timerTrigger >> intervalDelay
+-- | 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

@@ -1,6 +1,4 @@
 {-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes            #-}
 
 module Control.Concurrent.Async.Timer.Unsafe
   ( Timer
@@ -11,23 +9,31 @@ module Control.Concurrent.Async.Timer.Unsafe
   , timerWait
   ) where
 
-import qualified Control.Concurrent.Async.Lifted         as Unsafe
+import           Control.Concurrent.Async.Lifted
 import           Control.Concurrent.Async.Timer.Internal
 import           Control.Concurrent.Lifted
-import           Control.Monad
+import           Control.Exception.Safe
 import           Control.Monad.Trans.Control
 
-withAsyncTimer :: forall m b. (MonadBaseControl IO m)
+-- | 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 }
-      timerTrigger = void $ tryPutMVar mVar ()
-      initDelay'   = toMicroseconds $ _timerConfInitDelay conf
-      interval'    = toMicroseconds $ _timerConfInterval  conf
-      timerThread  = timerLoop (threadDelay initDelay')
-                               (threadDelay interval')
-                               timerTrigger
-  Unsafe.withAsync timerThread $ const (io timer)
-
-  where toMicroseconds x = x * (10 ^ 3)
+  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

@@ -34,36 +34,34 @@ test1 :: IO ()
 test1 = do
   let conf = defaultTimerConf & timerConfSetInitDelay    0
                               & timerConfSetInterval  1000 -- ms
+      noOfTicks = 5
 
   counter <- newIORef 0
   times <- newIORef []
 
-  withAsyncTimer conf $ \ timer -> do
-    forM_ [1..10] $ \_ -> do
+  withAsyncTimer conf $ \ timer ->
+    forM_ [1..noOfTicks] $ \_ -> do
       timerWait timer
       void $ forkIO $ myAction counter times
 
-  threadDelay 1000
+  threadDelay (5 * 10^5)
   n <- readIORef counter
-  n @?= 10
+  n @?= noOfTicks
 
   ts <- readIORef times
   let deltas = case ts of
                  []         -> []
-                 _ : tsTail -> map (\ (a, b) -> a - b) $ zip ts tsTail
+                 _ : tsTail -> zipWith (-) ts tsTail
 
-      diff   = sum deltas - 9
+      avgDiff = sum (map (subtract 1) deltas) / fromIntegral (length deltas)
   forM_ deltas (\ dt -> putStrLn $ "dt = " ++ show dt)
-  putStrLn $ "average dt = " ++ show diff
+  putStrLn $ "average dt = " ++ show avgDiff
   return ()
 
   where myAction :: IORef Int -> IORef [Double] -> IO ()
         myAction counter times = do
           t <- getTime
           n <- readIORef counter
-          if n == 10
-             then throwIO MyException
-             else return ()
           let n' = n + 1
           writeIORef counter n'
           modifyIORef times (t :)