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
catchTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Maybe a)
catchTimeout action = catch (Just <$> action) $ \ Timeout' -> return Nothing
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
delay :: (TimeUnit t, MonadIO m) => t -> m ()
delay = delayInteger . toMicroseconds