-- 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 = m () -> ContT r m ()
forall (m :: * -> *) a. Monad m => m a -> ContT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ContT r m ())
-> (DiffTime -> m ()) -> DiffTime -> ContT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay
instance (Monoid w, MonadDelay m) => MonadDelay (WriterT w m) where
  threadDelay :: DiffTime -> WriterT w m ()
threadDelay = m () -> WriterT w m ()
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WriterT w m ())
-> (DiffTime -> m ()) -> DiffTime -> WriterT w m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay
instance MonadDelay m => MonadDelay (StateT s m) where
  threadDelay :: DiffTime -> StateT s m ()
threadDelay = m () -> StateT s m ()
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (DiffTime -> m ()) -> DiffTime -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay
instance MonadDelay m => MonadDelay (ExceptT e m) where
  threadDelay :: DiffTime -> ExceptT e m ()
threadDelay = m () -> ExceptT e m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT e m ())
-> (DiffTime -> m ()) -> DiffTime -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m ()
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 = m () -> RWST r w s m ()
forall (m :: * -> *) a. Monad m => m a -> RWST r w s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RWST r w s m ())
-> (DiffTime -> m ()) -> DiffTime -> RWST r w s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m ()
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            = m (TVar m Bool) -> WriterT w m (TVar m Bool)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (TVar m Bool) -> WriterT w m (TVar m Bool))
-> (DiffTime -> m (TVar m Bool))
-> DiffTime
-> WriterT w m (TVar m Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m (TVar m Bool)
forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay
  registerDelayCancellable :: DiffTime
-> WriterT w m (STM (WriterT w m) TimeoutState, WriterT w m ())
registerDelayCancellable = ((STM m TimeoutState, m ())
 -> (WriterT w (STM m) TimeoutState, WriterT w m ()))
-> WriterT w m (STM m TimeoutState, m ())
-> WriterT w m (WriterT w (STM m) TimeoutState, WriterT w m ())
forall a b. (a -> b) -> WriterT w m a -> WriterT w m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((STM m TimeoutState -> WriterT w (STM m) TimeoutState)
-> (m () -> WriterT w m ())
-> (STM m TimeoutState, m ())
-> (WriterT w (STM m) TimeoutState, WriterT w m ())
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap STM m TimeoutState -> WriterT w (STM m) TimeoutState
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m () -> WriterT w m ()
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)
                           (WriterT w m (STM m TimeoutState, m ())
 -> WriterT w m (WriterT w (STM m) TimeoutState, WriterT w m ()))
-> (DiffTime -> WriterT w m (STM m TimeoutState, m ()))
-> DiffTime
-> WriterT w m (WriterT w (STM m) TimeoutState, WriterT w m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (STM m TimeoutState, m ())
-> WriterT w m (STM m TimeoutState, m ())
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                           (m (STM m TimeoutState, m ())
 -> WriterT w m (STM m TimeoutState, m ()))
-> (DiffTime -> m (STM m TimeoutState, m ()))
-> DiffTime
-> WriterT w m (STM m TimeoutState, m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m (STM m TimeoutState, m ())
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   = m (Maybe a, w) -> WriterT w m (Maybe a)
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (Maybe a, w) -> WriterT w m (Maybe a))
-> m (Maybe a, w) -> WriterT w m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
    Maybe (a, w)
r <- DiffTime -> m (a, w) -> m (Maybe (a, w))
forall a. DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
d (WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT w m a
f)
    (Maybe a, w) -> m (Maybe a, w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe a, w) -> m (Maybe a, w)) -> (Maybe a, w) -> m (Maybe a, w)
forall a b. (a -> b) -> a -> b
$ case Maybe (a, w)
r of
      Maybe (a, w)
Nothing     -> (Maybe a
forall a. Maybe a
Nothing, w
forall a. Monoid a => a
mempty)
      Just (a
a, w
w) -> (a -> Maybe a
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            = m (TVar m Bool) -> StateT s m (TVar m Bool)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (TVar m Bool) -> StateT s m (TVar m Bool))
-> (DiffTime -> m (TVar m Bool))
-> DiffTime
-> StateT s m (TVar m Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m (TVar m Bool)
forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay
  registerDelayCancellable :: DiffTime
-> StateT s m (STM (StateT s m) TimeoutState, StateT s m ())
registerDelayCancellable = ((STM m TimeoutState, m ())
 -> (StateT s (STM m) TimeoutState, StateT s m ()))
-> StateT s m (STM m TimeoutState, m ())
-> StateT s m (StateT s (STM m) TimeoutState, StateT s m ())
forall a b. (a -> b) -> StateT s m a -> StateT s m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((STM m TimeoutState -> StateT s (STM m) TimeoutState)
-> (m () -> StateT s m ())
-> (STM m TimeoutState, m ())
-> (StateT s (STM m) TimeoutState, StateT s m ())
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap STM m TimeoutState -> StateT s (STM m) TimeoutState
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m () -> StateT s m ()
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)
                           (StateT s m (STM m TimeoutState, m ())
 -> StateT s m (StateT s (STM m) TimeoutState, StateT s m ()))
-> (DiffTime -> StateT s m (STM m TimeoutState, m ()))
-> DiffTime
-> StateT s m (StateT s (STM m) TimeoutState, StateT s m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (STM m TimeoutState, m ())
-> StateT s m (STM m TimeoutState, m ())
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                           (m (STM m TimeoutState, m ())
 -> StateT s m (STM m TimeoutState, m ()))
-> (DiffTime -> m (STM m TimeoutState, m ()))
-> DiffTime
-> StateT s m (STM m TimeoutState, m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m (STM m TimeoutState, m ())
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 = (s -> m (Maybe a, s)) -> StateT s m (Maybe a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (Maybe a, s)) -> StateT s m (Maybe a))
-> (s -> m (Maybe a, s)) -> StateT s m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \s
s -> do
    Maybe (a, s)
r <- DiffTime -> m (a, s) -> m (Maybe (a, s))
forall a. DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
d (StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT s m a
f s
s)
    (Maybe a, s) -> m (Maybe a, s)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe a, s) -> m (Maybe a, s)) -> (Maybe a, s) -> m (Maybe a, s)
forall a b. (a -> b) -> a -> b
$ case Maybe (a, s)
r of
      Maybe (a, s)
Nothing      -> (Maybe a
forall a. Maybe a
Nothing, s
s)
      Just (a
a, s
s') -> (a -> Maybe a
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            = m (TVar m Bool) -> RWST r w s m (TVar m Bool)
forall (m :: * -> *) a. Monad m => m a -> RWST r w s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (TVar m Bool) -> RWST r w s m (TVar m Bool))
-> (DiffTime -> m (TVar m Bool))
-> DiffTime
-> RWST r w s m (TVar m Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m (TVar m Bool)
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 = ((STM m TimeoutState, m ())
 -> (RWST r w s (STM m) TimeoutState, RWST r w s m ()))
-> RWST r w s m (STM m TimeoutState, m ())
-> RWST r w s m (RWST r w s (STM m) TimeoutState, RWST r w s m ())
forall a b. (a -> b) -> RWST r w s m a -> RWST r w s m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((STM m TimeoutState -> RWST r w s (STM m) TimeoutState)
-> (m () -> RWST r w s m ())
-> (STM m TimeoutState, m ())
-> (RWST r w s (STM m) TimeoutState, RWST r w s m ())
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap STM m TimeoutState -> RWST r w s (STM m) TimeoutState
forall (m :: * -> *) a. Monad m => m a -> RWST r w s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m () -> RWST r w s m ()
forall (m :: * -> *) a. Monad m => m a -> RWST r w s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)
                           (RWST r w s m (STM m TimeoutState, m ())
 -> RWST r w s m (RWST r w s (STM m) TimeoutState, RWST r w s m ()))
-> (DiffTime -> RWST r w s m (STM m TimeoutState, m ()))
-> DiffTime
-> RWST r w s m (RWST r w s (STM m) TimeoutState, RWST r w s m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (STM m TimeoutState, m ())
-> RWST r w s m (STM m TimeoutState, m ())
forall (m :: * -> *) a. Monad m => m a -> RWST r w s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                           (m (STM m TimeoutState, m ())
 -> RWST r w s m (STM m TimeoutState, m ()))
-> (DiffTime -> m (STM m TimeoutState, m ()))
-> DiffTime
-> RWST r w s m (STM m TimeoutState, m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m (STM m TimeoutState, m ())
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) = (r -> s -> m (Maybe a, s, w)) -> RWST r w s m (Maybe a)
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST ((r -> s -> m (Maybe a, s, w)) -> RWST r w s m (Maybe a))
-> (r -> s -> m (Maybe a, s, w)) -> RWST r w s m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \r
r s
s -> do
    Maybe (a, s, w)
res <- DiffTime -> m (a, s, w) -> m (Maybe (a, s, w))
forall a. DiffTime -> m a -> m (Maybe a)
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)
    (Maybe a, s, w) -> m (Maybe a, s, w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe a, s, w) -> m (Maybe a, s, w))
-> (Maybe a, s, w) -> m (Maybe a, s, w)
forall a b. (a -> b) -> a -> b
$ case Maybe (a, s, w)
res of
      Maybe (a, s, w)
Nothing         -> (Maybe a
forall a. Maybe a
Nothing, s
s, w
forall a. Monoid a => a
mempty)
      Just (a
a, s
s', w
w) -> (a -> Maybe a
forall a. a -> Maybe a
Just a
a, s
s', w
w)