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

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

import           Control.Monad.Cont (ContT (..))
import           Control.Monad.Except (ExceptT (..))
import           Control.Monad.RWS (RWST (..))
import           Control.Monad.State (StateT (..))
import           Control.Monad.Trans (lift)
import           Control.Monad.Writer (WriterT (..))

import           Control.Monad.Class.MonadTimer.SI

import           Control.Monad.Class.MonadTime.SI.Trans ()
import           Control.Monad.Class.MonadTimer.Trans ()

import           Data.Bifunctor (bimap)


instance MonadDelay m => MonadDelay (ContT r m) where
  threadDelay :: DiffTime -> ContT r m ()
threadDelay = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay
instance (Monoid w, MonadDelay m) => MonadDelay (WriterT w m) where
  threadDelay :: DiffTime -> WriterT w m ()
threadDelay = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay
instance MonadDelay m => MonadDelay (StateT s m) where
  threadDelay :: DiffTime -> StateT s m ()
threadDelay = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay
instance MonadDelay m => MonadDelay (ExceptT e m) where
  threadDelay :: DiffTime -> ExceptT e m ()
threadDelay = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay
instance (Monoid w, MonadDelay m) => MonadDelay (RWST r w s m) where
  threadDelay :: DiffTime -> RWST r w s m ()
threadDelay = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay

instance (Monoid w, MonadTimer m) => MonadTimer (WriterT w m) where
  registerDelay :: DiffTime -> WriterT w m (TVar (WriterT w m) Bool)
registerDelay            = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay
  registerDelayCancellable :: DiffTime
-> WriterT w m (STM (WriterT w m) TimeoutState, WriterT w m ())
registerDelayCancellable = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)
                           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadTimer m =>
DiffTime -> m (STM m TimeoutState, m ())
registerDelayCancellable
  timeout :: forall a. DiffTime -> WriterT w m a -> WriterT w m (Maybe a)
timeout DiffTime
d WriterT w m a
f   = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT forall a b. (a -> b) -> a -> b
$ do
    Maybe (a, w)
r <- forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
d (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT w m a
f)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (a, w)
r of
      Maybe (a, w)
Nothing     -> (forall a. Maybe a
Nothing, forall a. Monoid a => a
mempty)
      Just (a
a, w
w) -> (forall a. a -> Maybe a
Just a
a, w
w)

instance MonadTimer m => MonadTimer (StateT s m) where
  registerDelay :: DiffTime -> StateT s m (TVar (StateT s m) Bool)
registerDelay            = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay
  registerDelayCancellable :: DiffTime
-> StateT s m (STM (StateT s m) TimeoutState, StateT s m ())
registerDelayCancellable = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)
                           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadTimer m =>
DiffTime -> m (STM m TimeoutState, m ())
registerDelayCancellable
  timeout :: forall a. DiffTime -> StateT s m a -> StateT s m (Maybe a)
timeout DiffTime
d StateT s m a
f = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \s
s -> do
    Maybe (a, s)
r <- forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
d (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT s m a
f s
s)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (a, s)
r of
      Maybe (a, s)
Nothing      -> (forall a. Maybe a
Nothing, s
s)
      Just (a
a, s
s') -> (forall a. a -> Maybe a
Just a
a, s
s')

instance (Monoid w, MonadTimer m) => MonadTimer (RWST r w s m) where
  registerDelay :: DiffTime -> RWST r w s m (TVar (RWST r w s m) Bool)
registerDelay            = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay
  registerDelayCancellable :: DiffTime
-> RWST r w s m (STM (RWST r w s m) TimeoutState, RWST r w s m ())
registerDelayCancellable = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)
                           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadTimer m =>
DiffTime -> m (STM m TimeoutState, m ())
registerDelayCancellable
  timeout :: forall a. DiffTime -> RWST r w s m a -> RWST r w s m (Maybe a)
timeout DiffTime
d (RWST r -> s -> m (a, s, w)
f) = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s -> do
    Maybe (a, s, w)
res <- forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
d (r -> s -> m (a, s, w)
f r
r s
s)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (a, s, w)
res of
      Maybe (a, s, w)
Nothing         -> (forall a. Maybe a
Nothing, s
s, forall a. Monoid a => a
mempty)
      Just (a
a, s
s', w
w) -> (forall a. a -> Maybe a
Just a
a, s
s', w
w)