Trans.hs

-- undecidable instances needed for 'ContTSTM' instances of
-- 'MonadThrow' and 'MonadCatch' type classes.
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans      #-}

module Control.Monad.Class.MonadTimer.Trans () where

import           Control.Monad.Cont (ContT (..))
import           Control.Monad.Except (ExceptT (..))
import            Control.Monad.Trans (lift)
import qualified Control.Monad.RWS.Lazy as Lazy
import qualified Control.Monad.RWS.Strict as Strict
import qualified Control.Monad.State.Lazy as Lazy
import qualified Control.Monad.State.Strict as Strict
import qualified Control.Monad.Writer.Lazy as Lazy
import qualified Control.Monad.Writer.Strict as Strict

import           Control.Monad.Class.MonadTimer

import           Control.Monad.Class.MonadSTM.Trans ()

instance MonadDelay m => MonadDelay (ContT r m) where
  threadDelay = lift . threadDelay

instance (Monoid w, MonadDelay m) => MonadDelay (Lazy.WriterT w m) where
  threadDelay = lift . threadDelay

instance (Monoid w, MonadDelay m) => MonadDelay (Strict.WriterT w m) where
  threadDelay = lift . threadDelay

instance MonadDelay m => MonadDelay (Lazy.StateT s m) where
  threadDelay = lift . threadDelay

instance MonadDelay m => MonadDelay (Strict.StateT s m) where
  threadDelay = lift . threadDelay

instance MonadDelay m => MonadDelay (ExceptT e m) where
  threadDelay = lift . threadDelay

instance (Monoid w, MonadDelay m) => MonadDelay (Lazy.RWST r w s m) where
  threadDelay = lift . threadDelay

instance (Monoid w, MonadDelay m) => MonadDelay (Strict.RWST r w s m) where
  threadDelay = lift . threadDelay

instance (Monoid w, MonadTimer m) => MonadTimer (Lazy.WriterT w m) where
  registerDelay = lift . registerDelay
  timeout d f   = Lazy.WriterT $ do
    r <- timeout d (Lazy.runWriterT f)
    return $ case r of
      Nothing     -> (Nothing, mempty)
      Just (a, w) -> (Just a, w)

instance (Monoid w, MonadTimer m) => MonadTimer (Strict.WriterT w m) where
  registerDelay = lift . registerDelay
  timeout d f   = Strict.WriterT $ do
    r <- timeout d (Strict.runWriterT f)
    return $ case r of
      Nothing     -> (Nothing, mempty)
      Just (a, w) -> (Just a, w)

instance MonadTimer m => MonadTimer (Lazy.StateT s m) where
  registerDelay = lift . registerDelay
  timeout d f = Lazy.StateT $ \s -> do
    r <- timeout d (Lazy.runStateT f s)
    return $ case r of
      Nothing      -> (Nothing, s)
      Just (a, s') -> (Just a, s')

instance MonadTimer m => MonadTimer (Strict.StateT s m) where
  registerDelay = lift . registerDelay
  timeout d f = Strict.StateT $ \s -> do
    r <- timeout d (Strict.runStateT f s)
    return $ case r of
      Nothing      -> (Nothing, s)
      Just (a, s') -> (Just a, s')

instance (Monoid w, MonadTimer m) => MonadTimer (Lazy.RWST r w s m) where
  registerDelay = lift . registerDelay
  timeout d (Lazy.RWST f) = Lazy.RWST $ \r s -> do
    res <- timeout d (f r s)
    return $ case res of
      Nothing         -> (Nothing, s, mempty)
      Just (a, s', w) -> (Just a, s', w)

instance (Monoid w, MonadTimer m) => MonadTimer (Strict.RWST r w s m) where
  registerDelay = lift . registerDelay
  timeout d (Strict.RWST f) = Strict.RWST $ \r s -> do
    res <- timeout d (f r s)
    return $ case res of
      Nothing         -> (Nothing, s, mempty)
      Just (a, s', w) -> (Just a, s', w)