-- |Module `Time` include useful functions for working calculations which must
--  be done after a certain period of time.
module Time (
    TimeAccuracy (MS, S, M, H),
    MonadTimeout,
    timeout,
    timeout',
  ) where

import Control.DeepSeq (NFData, force)
import Control.Exception (evaluate)
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Timeout as T
import qualified Control.Monad.Reader as R
import qualified Control.Monad.State.Lazy as S

data TimeAccuracy =
    MS
  | S
  | M
  | H

toMS :: RealFrac i => i -> TimeAccuracy -> i
toMS :: i -> TimeAccuracy -> i
toMS i
t TimeAccuracy
MS = i
t
toMS i
t TimeAccuracy
S  = i
t i -> i -> i
forall a. Num a => a -> a -> a
* i
1000.0
toMS i
t TimeAccuracy
M  = i
t i -> i -> i
forall a. Num a => a -> a -> a
* i
60000.0
toMS i
t TimeAccuracy
H  = i
t i -> i -> i
forall a. Num a => a -> a -> a
* i
3600000.0

timeout' :: RealFrac i => i -> TimeAccuracy -> IO a -> IO (Maybe a)
timeout' :: i -> TimeAccuracy -> IO a -> IO (Maybe a)
timeout' i
t TimeAccuracy
ta = Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
T.timeout (i -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (i -> Int) -> i -> Int
forall a b. (a -> b) -> a -> b
$ i -> TimeAccuracy -> i
forall i. RealFrac i => i -> TimeAccuracy -> i
toMS i
t TimeAccuracy
ta i -> i -> i
forall a. Num a => a -> a -> a
* i
1000.0)

class Monad m => MonadTimeout m where
    timeout :: (RealFrac i, NFData a) => i -> TimeAccuracy -> m a -> m a

instance MonadTimeout IO where
    timeout :: i -> TimeAccuracy -> IO a -> IO a
timeout i
t TimeAccuracy
ta IO a
a = do
        Maybe a
maybeRes <- i -> TimeAccuracy -> IO a -> IO (Maybe a)
forall i a. RealFrac i => i -> TimeAccuracy -> IO a -> IO (Maybe a)
timeout' i
t TimeAccuracy
ta IO a
a
        case Maybe a
maybeRes of
            Maybe a
Nothing  -> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Computation is so long"
            Just a
res -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

instance MonadTimeout Maybe where
    timeout :: i -> TimeAccuracy -> Maybe a -> Maybe a
timeout i
t TimeAccuracy
ta Maybe a
a = do
        a
val <- Maybe a
a
        IO (Maybe a) -> Maybe a
forall a. IO a -> a
unsafePerformIO (IO (Maybe a) -> Maybe a) -> IO (Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ i -> TimeAccuracy -> IO a -> IO (Maybe a)
forall i a. RealFrac i => i -> TimeAccuracy -> IO a -> IO (Maybe a)
timeout' i
t TimeAccuracy
ta (IO a -> IO (Maybe a)) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
evaluate (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. NFData a => a -> a
force a
val

instance MonadTimeout m => MonadTimeout (R.ReaderT r m) where
    timeout :: i -> TimeAccuracy -> ReaderT r m a -> ReaderT r m a
timeout i
t TimeAccuracy
ta (R.ReaderT r -> m a
a) = (r -> m a) -> ReaderT r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
R.ReaderT ((r -> m a) -> ReaderT r m a) -> (r -> m a) -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ i -> TimeAccuracy -> m a -> m a
forall (m :: * -> *) i a.
(MonadTimeout m, RealFrac i, NFData a) =>
i -> TimeAccuracy -> m a -> m a
timeout i
t TimeAccuracy
ta (m a -> m a) -> (r -> m a) -> r -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m a
a

instance MonadTimeout m => MonadTimeout (S.StateT s m) where
    timeout :: i -> TimeAccuracy -> StateT s m a -> StateT s m a
timeout i
t TimeAccuracy
ta (S.StateT s -> m (a, s)
a) = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
S.StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> do
        (a
val, s
s') <- s -> m (a, s)
a s
s
        a
val' <- i -> TimeAccuracy -> m a -> m a
forall (m :: * -> *) i a.
(MonadTimeout m, RealFrac i, NFData a) =>
i -> TimeAccuracy -> m a -> m a
timeout i
t TimeAccuracy
ta (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val
        (a, s) -> m (a, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
val', s
s')