packages feed

time-out 0.1 → 0.2

raw patch · 11 files changed

+852/−88 lines, 11 filesdep +data-default-classdep +time-intervaldep +time-outdep ~base

Dependencies added: data-default-class, time-interval, time-out

Dependency ranges changed: base

Files

NEWS.md view
@@ -3,6 +3,31 @@   +time-out 0.2        2016-05-30+==============================++General, build and documentation changes:++* `Control.TimeOut` becomes `Control.Timeout`++New APIs, features and enhancements:++* Several new timer and timeout related tools, see their haddocks++Bug fixes:++* (None)++Dependency changes:++* Add data-default-class+      time-interval+* Require time-interval >= 0.1.1+++++ time-out 0.1        2016-03-17 ==============================
+ src/Control/Alarm.hs view
@@ -0,0 +1,121 @@+{- This file is part of time-out.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- | Manage an alarm clock running in a dedicated thread.+--+-- You specify an amount of time. The alarm clock waits for that amount of+-- time, and then throws an exception back to you, to notify you the time has+-- passed. You can stop and restart it at any time.+--+-- This is simply a convenient wrapper over "Control.Timer", offered here+-- becuase a common use of timers is to run actions with a time limit+-- (timeout), and the API here makes it more straight-forward to do.+module Control.Alarm+    ( -- * Types+      Alarm ()+    , AlarmWake+      -- * Creating and destroying alarm+    , newAlarm+    , releaseAlarm+    , withAlarm+      -- * Starting an alarm+    , startAlarm+    , startAlarm'+      -- * Stopping a alarm+    , stopAlarm+      -- * Restarting a alarm+    , restartAlarm+    , restartAlarm'+      -- * Higher level functions+    , alarm+    , alarm'+    )+where++import Control.Concurrent+import Control.Monad (when)+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Timer+import Data.Default.Class (def)+import Data.Maybe (isJust)+import Data.Time.Interval (fromTimeUnit)+import Data.Time.Units (TimeUnit, Second)++newtype Alarm = Alarm { unAlarm :: Timer IO }++data AlarmWake = AlarmWake deriving Show++instance Exception AlarmWake++newAlarm :: (TimeUnit t, MonadIO m) => t -> m Alarm+newAlarm t = do+    tid <- liftIO myThreadId+    let sets = (def :: TimerSettings IO)+            { tsDelay  = fromTimeUnit t+            , tsRun    = id+            , tsAction = throwTo tid AlarmWake+            }+    Alarm <$> newTimer sets++releaseAlarm :: MonadIO m => Alarm -> m ()+releaseAlarm = releaseTimer . unAlarm++withAlarm+    :: (TimeUnit t, MonadIO m, MonadMask m)+    => t+    -> (Alarm -> m a)+    -> m a+withAlarm t = bracket (newAlarm t) releaseAlarm++startAlarm :: MonadIO m => Alarm -> m ()+startAlarm = startTimer . unAlarm++startAlarm' :: (TimeUnit t, MonadIO m) => Alarm -> t -> m ()+startAlarm' = startTimer' . unAlarm++stopAlarm :: MonadIO m => Alarm -> m ()+stopAlarm = stopTimer . unAlarm++restartAlarm :: MonadIO m => Alarm -> m ()+restartAlarm = restartTimer . unAlarm++restartAlarm' :: (TimeUnit t, MonadIO m) => Alarm -> t -> m ()+restartAlarm' = restartTimer' . unAlarm++alarmImpl+    :: (TimeUnit t, MonadIO m, MonadCatch m)+    => Alarm+    -> Maybe t+    -> m a+    -> m (Maybe a)+alarmImpl alm mt action = do+    case mt of+        Nothing -> startAlarm alm+        Just t  -> startAlarm' alm t+    result <- catch (Just <$> action) $ \ AlarmWake -> return Nothing+    when (isJust result) $ stopAlarm alm+    return result++alarm :: (MonadIO m, MonadCatch m) => Alarm -> m a -> m (Maybe a)+alarm alm action = alarmImpl alm (Nothing :: Maybe Second) action++alarm'+    :: (TimeUnit t, MonadIO m, MonadCatch m)+    => Alarm+    -> t+    -> m a+    -> m (Maybe a)+alarm' alm t action = alarmImpl alm (Just t) action
+ src/Control/Monad/Timeout/Class.hs view
@@ -0,0 +1,51 @@+{- This file is part of time-out.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE MultiParamTypeClasses #-}++-- | A typeclass for monads which can run actions with a time limit.+module Control.Monad.Timeout.Class+    ( Timeout (..)+    , MonadTimeout (..)+    )+where++import Control.Exception (Exception)+import Data.Time.Units (TimeUnit)++-- | Timeout exception. Thrown when an action is executed with a time limit,+-- and the time passes before the action finishes.+data Timeout = Timeout deriving Show++instance Exception Timeout++-- | A class for monads capable of executing computations with a time limit.+-- This class provides a uniform interface to the various possible+-- implementations.+--+-- For example, a trivial implementation may launch a helper thread for each+-- time-limited action. A more scalable implementation, preferred for some+-- cases, may keep a single dedicated thread and reuse it instead of starting+-- new ones.+class (Monad p, Monad m) => MonadTimeout m p where+    -- | Execute an action with a time limit. If the action finishes before the+    -- given time passes, return the value it returned. If the time passes and+    -- the action hasn't finished yet, throw a 'Timeout' exception.+    timeoutThrow :: TimeUnit t => t -> p a -> m a++    -- | Execute an action with a time limit. If the action finishes before the+    -- given time passes, return 'Just' the value it returned. If the time+    -- passes and the action hasn't finished yet, return 'Nothing'.+    timeoutCatch :: TimeUnit t => t -> p a -> m (Maybe a)
+ src/Control/Monad/Trans/Alarm.hs view
@@ -0,0 +1,99 @@+{- This file is part of time-out.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Monad transformer for managing an alarm clock.+module Control.Monad.Trans.Alarm+    ( -- * Transformer+      AlarmT ()+    , runAlarmT+      -- * Starting an alarm+    , startAlarm+    , startAlarm'+      -- * Stopping an alarm+    , stopAlarm+      -- * Restarting an alarm+    , restartAlarm+    , restartAlarm'+      -- * Higher level functions+    , alarm+    , alarm'+    )+where++import Control.Monad.Catch+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Data.Time.Units (TimeUnit)++import qualified Control.Alarm as A++newtype AlarmT m a = AlarmT+    { unAT :: ReaderT A.Alarm m a+    }+    deriving+        ( -- Basics+          Functor+        , Applicative+        , Monad+          -- Extra monads from base+        , MonadFix+          -- Thread operations are IO+        , MonadIO+          -- This is a transformer after all+        , MonadTrans+          -- Exceptions+        , MonadCatch+        , MonadThrow+        , MonadMask+        )++askAlarm :: Monad m => AlarmT m A.Alarm+askAlarm = AlarmT ask++runAlarmT :: (TimeUnit t, MonadIO m, MonadMask m) => AlarmT m a -> t -> m a+runAlarmT act t = A.withAlarm t $ runReaderT $ unAT act++startAlarm :: MonadIO m => AlarmT m ()+startAlarm = askAlarm >>= A.startAlarm++startAlarm' :: (TimeUnit t, MonadIO m) => t -> AlarmT m ()+startAlarm' t = askAlarm >>= flip A.startAlarm' t++stopAlarm :: MonadIO m => AlarmT m ()+stopAlarm = askAlarm >>= A.stopAlarm++restartAlarm :: MonadIO m => AlarmT m ()+restartAlarm = askAlarm >>= A.restartAlarm++restartAlarm' :: (TimeUnit t, MonadIO m) => t -> AlarmT m ()+restartAlarm' t = askAlarm >>= flip A.restartAlarm' t++alarm :: (MonadIO m, MonadCatch m) => m a -> AlarmT m (Maybe a)+alarm action = do+    alm <- askAlarm+    lift $ A.alarm alm action++alarm'+    :: (TimeUnit t, MonadIO m, MonadCatch m)+    => t+    -> m a+    -> AlarmT m (Maybe a)+alarm' t action = do+    alm <- askAlarm+    lift $ A.alarm' alm t action
+ src/Control/Monad/Trans/Timeout.hs view
@@ -0,0 +1,101 @@+{- This file is part of time-out.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}++-- | Monad transformer for running actions with a time limit. Provides a+-- scalable @MonadTimeout@ instance (at least for the case of a constant number+-- of long-running threads). If you need to use timeouts often in a+-- computation, this is probably better than "Control.Timeout".+module Control.Monad.Trans.Timeout+    ( TimeoutT ()+    , runTimeoutT+    , withTimeoutThrow+    , withTimeoutThrow'+    , withTimeoutCatch+    , withTimeoutCatch'+    )+where++import Control.Monad.Catch+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class+import Control.Monad.Timeout.Class+import Control.Monad.Trans.Alarm+import Control.Monad.Trans.Class+import Data.Time.Units (TimeUnit)++-- | Monad transformer which gives your monad stack an ability to run actions+-- with a timeout, and abort them if they don't finish within the time limit.+--+-- By default, e.g. if you 'lift' or 'liftIO' an action, it runs in the regular+-- way without a timeout. Use one of the timeout functions, such as+-- 'withTimeoutThrow', to use the timeout.+newtype TimeoutT m a = TimeoutT+    { unTT :: AlarmT m a+    }+    deriving+        ( -- Basics+          Functor+        , Applicative+        , Monad+          -- Extra monads from base+        , MonadFix+          -- Thread operations are IO+        , MonadIO+          -- This is a transformer after all+        , MonadTrans+          -- Exceptions+        , MonadCatch+        , MonadThrow+        , MonadMask+        )++instance (MonadIO m, MonadCatch m) => MonadTimeout (TimeoutT m) m where+    timeoutThrow = withTimeoutThrow'+    timeoutCatch = withTimeoutCatch'++runTimeoutT :: (TimeUnit t, MonadIO m, MonadMask m) => TimeoutT m a -> t -> m a+runTimeoutT act t = runAlarmT (unTT act) t++withTimeoutThrow :: (MonadIO m, MonadCatch m) => m a -> TimeoutT m a+withTimeoutThrow act = do+    mresult <- withTimeoutCatch act+    case mresult of+        Nothing     -> throwM Timeout+        Just result -> return result++withTimeoutThrow'+    :: (TimeUnit t, MonadIO m, MonadCatch m)+    => t+    -> m a+    -> TimeoutT m a+withTimeoutThrow' t act = do+    mresult <- withTimeoutCatch' t act+    case mresult of+        Nothing     -> throwM Timeout+        Just result -> return result++withTimeoutCatch :: (MonadIO m, MonadCatch m) => m a -> TimeoutT m (Maybe a)+withTimeoutCatch act = TimeoutT $ alarm act++withTimeoutCatch'+    :: (TimeUnit t, MonadCatch m, MonadIO m)+    => t+    -> m a+    -> TimeoutT m (Maybe a)+withTimeoutCatch' t act = TimeoutT $ alarm' t act
+ src/Control/Monad/Trans/Timer.hs view
@@ -0,0 +1,104 @@+{- This file is part of time-out.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Monad transformer for managing a timer.+module Control.Monad.Trans.Timer+    ( -- * Transformer+      TimerT ()+    , runTimerT+      -- * Starting a timer+    , startTimer+    , startTimer'+    , startTimerWith+      -- * Stopping a timer+    , stopTimer+      -- * Restarting a timer+    , restartTimer+    , restartTimer'+    , restartTimerWith+    )+where++import Control.Monad.Catch+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class (MonadTrans)+import Control.Monad.Trans.Reader+import Data.Time.Units (TimeUnit)++import qualified Control.Timer as T++newtype TimerT n m a = TimerT+    { unTT :: ReaderT (T.Timer n) m a+    }+    deriving+        ( -- Basics+          Functor+        , Applicative+        , Monad+          -- Extra monads from base+        , MonadFix+          -- Thread operations are IO+        , MonadIO+          -- This is a transformer after all+        , MonadTrans+          -- Exceptions+        , MonadCatch+        , MonadThrow+        , MonadMask+        )++askTimer :: Monad m => TimerT n m (T.Timer n)+askTimer = TimerT ask++runTimerT+    :: (MonadIO m, MonadMask m, MonadIO n, MonadCatch n)+    => TimerT n m a+    -> T.TimerSettings n+    -> m a+runTimerT act sets = T.withTimer sets $ runReaderT $ unTT act++startTimer :: MonadIO m => TimerT n m ()+startTimer = askTimer >>= T.startTimer++startTimer' :: (MonadIO m, TimeUnit t) => t -> TimerT n m ()+startTimer' t = askTimer >>= flip T.startTimer' t++startTimerWith+    :: (TimeUnit t, MonadIO m)+    => Maybe t+    -> Maybe (n ())+    -> TimerT n m ()+startTimerWith mtime maction =+    askTimer >>= \ timer -> T.startTimerWith timer mtime maction++stopTimer :: MonadIO m => TimerT n m ()+stopTimer = askTimer >>= T.stopTimer++restartTimer :: MonadIO m => TimerT n m ()+restartTimer = askTimer >>= T.restartTimer++restartTimer' :: (TimeUnit t, MonadIO m) => t -> TimerT n m ()+restartTimer' t = askTimer >>= flip T.restartTimer' t++restartTimerWith+    :: (TimeUnit t, MonadIO m)+    => Maybe t+    -> Maybe (n ())+    -> TimerT n m ()+restartTimerWith mtime maction =+    askTimer >>= \ timer -> T.restartTimerWith timer mtime maction
− src/Control/TimeOut.hs 
@@ -1,80 +0,0 @@-{- This file is part of time-out.- -- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}--module Control.TimeOut-    ( timeout-    , delay-    )-where--import Control.Concurrent-import Control.Monad (when)-import Control.Monad.Catch-import Control.Monad.IO.Class-import Data.List (genericReplicate)-import Data.Maybe (isJust)-import Data.Time.Units--data Timeout = Timeout deriving Show--instance Exception Timeout---- | If the action succeeds, return 'Just' the result. If a 'Timeout' exception--- is thrown during the action, catch it and return 'Nothing'. Other exceptions--- aren't caught.-catchTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Maybe a)-catchTimeout action = catch (Just <$> action) $ \ Timeout -> return Nothing---- | Run a monadic action with a time limit. If it finishes before that time--- passes and returns value @x@, then @Just x@ is returned. If the timeout--- passes, the action is aborted and @Nothing@ is returned. If the action--- throws an exception, it is aborted and the exception is rethrown.------ >>> timeout (3 :: Second) $ delay (1 :: Second) >> return "hello"--- Just "hello"------ >>> timeout (3 :: Second) $ delay (5 :: Second) >> return "hello"--- Nothing------ >>> timeout (1 :: Second) $ delay "hello"--- *** Exception: hello-timeout :: (TimeUnit t, MonadIO m, MonadCatch m) => t -> m a -> m (Maybe a)-timeout time action = do-    tidMain <- liftIO myThreadId-    tidTemp <- liftIO $ forkIO $ delay time >> throwTo tidMain Timeout-    result <- catchTimeout action `onException` liftIO (killThread tidTemp)-    when (isJust result) $ liftIO $ killThread tidTemp-    return result--delayInt :: MonadIO m => Int -> m ()-delayInt usec = liftIO $ threadDelay usec--delayInteger :: MonadIO m => Integer -> m ()-delayInteger usec =-    if usec > 0-        then do-            let maxInt = maxBound :: Int-                (times, rest) = usec `divMod` toInteger maxInt-            sequence_ $ genericReplicate times $ delayInt maxInt-            delayInt $ fromInteger rest-        else return ()---- | Suspend the current thread for the given amount of time.------ Example:------ > delay (5 :: Second)-delay :: (TimeUnit t, MonadIO m) => t -> m ()-delay = delayInteger . toMicroseconds
+ src/Control/Timeout.hs view
@@ -0,0 +1,90 @@+{- This file is part of time-out.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE MultiParamTypeClasses #-}++module Control.Timeout+    ( timeout+    , delay+    )+where++import Control.Concurrent+import Control.Monad (when)+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Timeout.Class+import Data.List (genericReplicate)+import Data.Maybe (isJust)+import Data.Time.Units++data Timeout' = Timeout' deriving Show++instance Exception Timeout'++instance MonadTimeout IO IO where+    timeoutThrow t act = do+        result <- timeoutCatch t act+        case result of+            Nothing -> throwM Timeout'+            Just a  -> return a++    timeoutCatch = timeout++-- | If the action succeeds, return 'Just' the result. If a timeout exception+-- is thrown during the action, catch it and return 'Nothing'. Other exceptions+-- aren't caught.+catchTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Maybe a)+catchTimeout action = catch (Just <$> action) $ \ Timeout' -> return Nothing++-- | Run a monadic action with a time limit. If it finishes before that time+-- passes and returns value @x@, then @Just x@ is returned. If the timeout+-- passes, the action is aborted and @Nothing@ is returned. If the action+-- throws an exception, it is aborted and the exception is rethrown.+--+-- >>> timeout (3 :: Second) $ delay (1 :: Second) >> return "hello"+-- Just "hello"+--+-- >>> timeout (3 :: Second) $ delay (5 :: Second) >> return "hello"+-- Nothing+--+-- >>> timeout (1 :: Second) $ error "hello"+-- *** Exception: hello+timeout :: (TimeUnit t, MonadIO m, MonadCatch m) => t -> m a -> m (Maybe a)+timeout time action = do+    tidMain <- liftIO myThreadId+    tidTemp <- liftIO $ forkIO $ delay time >> throwTo tidMain Timeout'+    result <- catchTimeout action `onException` liftIO (killThread tidTemp)+    when (isJust result) $ liftIO $ killThread tidTemp+    return result++delayInt :: MonadIO m => Int -> m ()+delayInt usec = liftIO $ threadDelay usec++delayInteger :: MonadIO m => Integer -> m ()+delayInteger usec =+    when (usec > 0) $ do+        let maxInt = maxBound :: Int+            (times, rest) = usec `divMod` toInteger maxInt+        sequence_ $ genericReplicate times $ delayInt maxInt+        delayInt $ fromInteger rest++-- | Suspend the current thread for the given amount of time.+--+-- Example:+--+-- > delay (5 :: Second)+delay :: (TimeUnit t, MonadIO m) => t -> m ()+delay = delayInteger . toMicroseconds
+ src/Control/Timer.hs view
@@ -0,0 +1,154 @@+{- This file is part of time-out.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- | Manage a timer running in a dedicated thread. You specify an amount of+-- time an and action. The timer waits for that amount of time, and then runs+-- the action. You can stop and restart it at any time.+module Control.Timer+    ( -- * Settings+      TimerSettings ()+    , tsDelay+    , tsRun+    , tsAction+      -- * Timer type+    , Timer ()+      -- * Creating and destroying timers+    , newTimer+    , releaseTimer+    , withTimer+      -- * Starting a timer+    , startTimer+    , startTimer'+    , startTimerWith+      -- * Stopping a timer+    , stopTimer+      -- * Restarting a timer+    , restartTimer+    , restartTimer'+    , restartTimerWith+    )+where++import Control.Concurrent+import Control.Monad (forever)+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Default.Class+import Data.Maybe (fromMaybe)+import Data.Time.Interval hiding (time)+import Data.Time.Units++import Control.Timeout (delay)++data StopTimer = StopTimer deriving Show++instance Exception StopTimer++data TimerSettings n = TimerSettings+    { tsDelay  :: TimeInterval+    , tsRun    :: n () -> IO ()+    , tsAction :: n ()+    }++instance MonadIO n => Default (TimerSettings n) where+    def = TimerSettings+        { tsDelay  = fromTimeUnit (3 :: Second)+        , tsRun    = const $ do+            let msg = "You didn't tell me how to run the monad"+            putStrLn msg+            error msg+        , tsAction = liftIO $ putStrLn "Time reached, timer has stopped!"+        }++type Msg n = (Maybe TimeInterval, Maybe (n ()))++data Timer n = Timer+    { timerThread :: ThreadId+    , timerMVar   :: MVar (Msg n)+    }++timerThreadLoop+    :: (MonadIO n, MonadCatch n)+    => TimerSettings n+    -> MVar (Msg n)+    -> IO ()+timerThreadLoop sets mvar =+    tsRun sets $ forever $ handle (\ StopTimer -> return ()) $ do+        -- wait until we need to start the timeout+        (mtime, maction) <- liftIO $ takeMVar mvar+        let time = fromMaybe (tsDelay sets) mtime+            action = fromMaybe (tsAction sets) maction+        -- wait the timeout time+        delay (fromMicroseconds $ microseconds time :: Microsecond)+        -- run the action+        action++newTimer+    :: (MonadIO m, MonadIO n, MonadCatch n)+    => TimerSettings n+    -> m (Timer n)+newTimer sets = do+    mvar <- liftIO newEmptyMVar+    tid <- liftIO $ forkIO $ timerThreadLoop sets mvar+    return Timer+        { timerThread = tid+        , timerMVar   = mvar+        }++releaseTimer :: MonadIO m => Timer n -> m ()+releaseTimer timer = liftIO $ killThread $ timerThread timer++withTimer+    :: (MonadIO m, MonadMask m, MonadIO n, MonadCatch n)+    => TimerSettings n+    -> (Timer n -> m a)+    -> m a+withTimer sets = bracket (newTimer sets) releaseTimer++startTimer :: MonadIO m => Timer n -> m ()+startTimer timer = startTimerWith timer (Nothing :: Maybe Second) Nothing++startTimer' :: (TimeUnit t, MonadIO m) => Timer n -> t -> m ()+startTimer' timer t = startTimerWith timer (Just t) Nothing++startTimerWith+    :: (TimeUnit t, MonadIO m)+    => Timer n+    -> Maybe t+    -> Maybe (n ())+    -> m ()+startTimerWith timer mtime maction =+    liftIO $ putMVar (timerMVar timer) (fromTimeUnit <$> mtime, maction)++stopTimer :: MonadIO m => Timer n -> m ()+stopTimer timer = liftIO $ do+    _ <- tryTakeMVar $ timerMVar timer+    throwTo (timerThread timer) StopTimer++restartTimer :: MonadIO m => Timer n -> m ()+restartTimer timer = restartTimerWith timer (Nothing :: Maybe Second) Nothing++restartTimer' :: (TimeUnit t, MonadIO m) => Timer n -> t -> m ()+restartTimer' timer t = restartTimerWith timer (Just t) Nothing++restartTimerWith+    :: (TimeUnit t, MonadIO m)+    => Timer n+    -> Maybe t+    -> Maybe (n ())+    -> m ()+restartTimerWith timer mtime maction = do+    stopTimer timer+    startTimerWith timer mtime maction
+ test/test.hs view
@@ -0,0 +1,55 @@+{- This file is part of time-out.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Timeout+import Control.Timeout+import Data.Maybe (isJust, isNothing, catMaybes)+import Data.Time.Units (Second)+import System.Exit (exitFailure)+import System.IO++tests :: [(Int, TimeoutT IO Bool)]+tests =+    [ ( 1+      , liftIO $ fmap isJust $ timeout (3 :: Second) $ delay (1 :: Second)+      )+    , ( 2+      , liftIO $ fmap isNothing $ timeout (3 :: Second) $ delay (5 :: Second)+      )+    , ( 3+      , fmap isJust $ withTimeoutCatch $ delay (1 :: Second)+      )+    , ( 4+      , fmap isNothing $ withTimeoutCatch $ delay (5 :: Second)+      )+    ]++runTest :: Int -> TimeoutT IO Bool -> TimeoutT IO (Maybe Int)+runTest num test = do+    result <- test+    return $ if result then Nothing else Just num++runTests :: [(Int, TimeoutT IO Bool)] -> TimeoutT IO [Int]+runTests = fmap catMaybes . traverse (uncurry runTest)++main :: IO ()+main = do+    fails <- runTimeoutT (runTests tests) (3 :: Second)+    if null fails+        then putStrLn "Success!"+        else do+            putStrLn $ "Failed: " ++ show fails+            exitFailure
time-out.cabal view
@@ -1,5 +1,5 @@ name: time-out-version: 0.1+version: 0.2 cabal-version: >=1.10 build-type: Simple license: PublicDomain@@ -8,13 +8,38 @@ maintainer: fr33domlover@riseup.net homepage: http://hub.darcs.net/fr33domlover/time-out bug-reports: mailto:fr33domlover@riseup.net-synopsis: Execute a computation with a timeout+synopsis: Timers, timeouts, alarms, monadic wrappers description:-    This simple library allows you to execute a computation with a limit on its-    running time. If it finishes within the specified limit, you get the result-    it returns. Otherwise, i.e. if it doesn't finish in time, it will be aborted-    and you'll be notified.-category: Control, Monad, Network+    This library provides several timer and timeout related tools:+    .+    * "Control.Timeout" - Execution of a computation with a time limit, aborting+    it if the limit is reached before the computation finishes. It is+    more-or-less a lifted version of "System.Timeout" from the @base@ package.+    It's good for single use, but it launches a temporary helper thread. If you+    want to time-limit actions continuously (e.g. if you're implementing a+    network protocol), you should probably use one of the other tools described+    below, since they use a single dedicated thread for all the timeouts.+    .+    * "Control.Timer" - Managing a timer running in a dedicated thread. The timer+    waits for an amount of time you specify, and then runs an action you+    specify. You can stop and restart it at any time.+    .+    * "Control.Alarm" - Managing an alarm, which is a timer whose action is to+    notify your thread when the specified amount of time passes.+    .+    * "Control.Monad.Trans.Timer" - A monad transformer for managing a timer+    .+    * "Control.Monad.Trans.Alarm" - A monad transformer for managing an alarm+    .+    * "Control.Monad.Trans.Timeout" - A monad transformer for running actions+    with timeouts, useful for e.g. network protocols where any send and receive+    can timeout+    .+    * "Control.Monad.Timeout.Class" - A monad typeclass for running actions with+    a time limit. "Control.Timeout" provides a simple trivial for IO (which can+    then be used with any @MonadIO@), and "Control.Monad.Trans.Timeout"+    provides a scalable instance.+category: Control, Monad, Time, Timeout author: fr33domlover extra-source-files:     AUTHORS@@ -30,12 +55,31 @@  library     exposed-modules:-        Control.TimeOut+        Control.Alarm+        Control.Monad.Timeout.Class+        Control.Monad.Trans.Alarm+        Control.Monad.Trans.Timeout+        Control.Monad.Trans.Timer+        Control.Timer+        Control.Timeout     build-depends:         base >=4.8 && <5,+        data-default-class >=0.0.1,         exceptions >=0.8.2.1,+        time-interval >=0.1.1,         time-units >=1.0.0,         transformers >=0.4.2.0     default-language: Haskell2010     hs-source-dirs: src+    ghc-options: -Wall +test-suite test+    type: exitcode-stdio-1.0+    main-is: test.hs+    build-depends:+        base >=4.8.2.0,+        time-out >=0.2,+        time-units >=1.0.0,+        transformers >=0.4.2.0+    default-language: Haskell2010+    hs-source-dirs: test