{-# LANGUAGE DefaultSignatures   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

-- | Provides classes to handle delays and timeouts which generalised
-- <https://hackage.haskell.org/package/base base> API to both 'IO' and
-- <https://hackage.haskell.org/package/io-sim IOSim>.
--
module Control.Monad.Class.MonadTimer
  ( MonadDelay (..)
  , MonadTimer (..)
  ) where

import Control.Concurrent qualified as IO
import Control.Concurrent.Class.MonadSTM
import Control.Concurrent.STM.TVar qualified as STM

import Control.Monad.Reader (ReaderT (..))
import Control.Monad.Trans (lift)

import System.Timeout qualified as IO

-- | A typeclass to delay current thread.
class Monad m => MonadDelay m where

  -- | Suspends the current thread for a given number of microseconds
  -- (GHC only).
  --
  -- See `IO.threadDelay`.
  threadDelay :: Int -> m ()

-- | A typeclass providing utilities for /timeouts/.
class (MonadDelay m, MonadSTM m) => MonadTimer m where

  -- | See `STM.registerDelay`.
  registerDelay :: Int -> m (TVar m Bool)

  -- | See `IO.timeout`.
  timeout :: Int -> m a -> m (Maybe a)

--
-- Instances for IO
--

instance MonadDelay IO where
  threadDelay :: Int -> IO ()
threadDelay = Int -> IO ()
IO.threadDelay


instance MonadTimer IO where

  registerDelay :: Int -> IO (TVar IO Bool)
registerDelay = Int -> IO (TVar Bool)
Int -> IO (TVar IO Bool)
STM.registerDelay
  timeout :: forall a. Int -> IO a -> IO (Maybe a)
timeout = Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
IO.timeout

--
-- Transformer's instances
--

instance MonadDelay m => MonadDelay (ReaderT r m) where
  threadDelay :: Int -> ReaderT r m ()
threadDelay = m () -> ReaderT r m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT r m ()) -> (Int -> m ()) -> Int -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m ()
forall (m :: * -> *). MonadDelay m => Int -> m ()
threadDelay

instance MonadTimer m => MonadTimer (ReaderT r m) where
  registerDelay :: Int -> ReaderT r m (TVar (ReaderT r m) Bool)
registerDelay = m (TVar m Bool) -> ReaderT r m (TVar m Bool)
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (TVar m Bool) -> ReaderT r m (TVar m Bool))
-> (Int -> m (TVar m Bool)) -> Int -> ReaderT r m (TVar m Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m (TVar m Bool)
forall (m :: * -> *). MonadTimer m => Int -> m (TVar m Bool)
registerDelay
  timeout :: forall a. Int -> ReaderT r m a -> ReaderT r m (Maybe a)
timeout Int
d ReaderT r m a
f   = (r -> m (Maybe a)) -> ReaderT r m (Maybe a)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m (Maybe a)) -> ReaderT r m (Maybe a))
-> (r -> m (Maybe a)) -> ReaderT r m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \r
r -> Int -> m a -> m (Maybe a)
forall a. Int -> m a -> m (Maybe a)
forall (m :: * -> *) a. MonadTimer m => Int -> m a -> m (Maybe a)
timeout Int
d (ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
f r
r)