{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Monad.Class.MonadTimer.SI
(
MonadDelay (..)
, MonadTimer (..)
, diffTimeToMicrosecondsAsInt
, microsecondsAsIntToDiffTime
, DiffTime
, MonadFork
, MonadMonotonicTime
, MonadTime
, TimeoutState (..)
, defaultRegisterDelay
, defaultRegisterDelayCancellable
) where
import Control.Concurrent.Class.MonadSTM
import Control.Exception (assert)
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer qualified as MonadTimer
import Control.Monad.Class.MonadTimer.NonStandard (TimeoutState (..))
import Control.Monad.Class.MonadTimer.NonStandard qualified as NonStandard
import Control.Monad.Reader
import Data.Bifunctor (bimap)
import Data.Functor (($>))
import Data.Time.Clock (diffTimeToPicoseconds)
diffTimeToMicrosecondsAsInt :: DiffTime -> Int
diffTimeToMicrosecondsAsInt :: DiffTime -> Int
diffTimeToMicrosecondsAsInt DiffTime
d =
let usec :: Integer
usec :: Integer
usec = DiffTime -> Integer
diffTimeToPicoseconds DiffTime
d Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1_000_000 in
Bool -> Int -> Int
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Integer
usec Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)
Bool -> Bool -> Bool
&& Integer
usec Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
minBound :: Int)) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$
Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
usec
microsecondsAsIntToDiffTime :: Int -> DiffTime
microsecondsAsIntToDiffTime :: Int -> DiffTime
microsecondsAsIntToDiffTime = (DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
1_000_000) (DiffTime -> DiffTime) -> (Int -> DiffTime) -> Int -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral
class ( MonadTimer.MonadDelay m
, MonadMonotonicTime m
) => MonadDelay m where
threadDelay :: DiffTime -> m ()
instance MonadDelay IO where
threadDelay :: forall m.
MonadDelay m
=> DiffTime -> m ()
threadDelay :: forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
d | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= DiffTime
0 = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
threadDelay DiffTime
d | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= DiffTime
maxDelay =
Int -> m ()
forall (m :: * -> *). MonadDelay m => Int -> m ()
MonadTimer.threadDelay (DiffTime -> Int
diffTimeToMicrosecondsAsInt DiffTime
d)
where
maxDelay :: DiffTime
maxDelay :: DiffTime
maxDelay = Int -> DiffTime
microsecondsAsIntToDiffTime Int
forall a. Bounded a => a
maxBound
threadDelay DiffTime
d = do
Time
c <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
let u :: Time
u = DiffTime
d DiffTime -> Time -> Time
`addTime` Time
c
Time -> Time -> m ()
go Time
c Time
u
where
maxDelay :: DiffTime
maxDelay :: DiffTime
maxDelay = Int -> DiffTime
microsecondsAsIntToDiffTime Int
forall a. Bounded a => a
maxBound
go :: Time -> Time -> m ()
go :: Time -> Time -> m ()
go Time
c Time
u = do
if DiffTime
d' DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
maxDelay
then do
Int -> m ()
forall (m :: * -> *). MonadDelay m => Int -> m ()
MonadTimer.threadDelay Int
forall a. Bounded a => a
maxBound
Time
c' <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
Time -> Time -> m ()
go Time
c' Time
u
else
Int -> m ()
forall (m :: * -> *). MonadDelay m => Int -> m ()
MonadTimer.threadDelay (DiffTime -> Int
diffTimeToMicrosecondsAsInt DiffTime
d')
where
d' :: DiffTime
d' = Time
u Time -> Time -> DiffTime
`diffTime` Time
c
instance MonadDelay m => MonadDelay (ReaderT r m) where
threadDelay :: DiffTime -> 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 ())
-> (DiffTime -> m ()) -> DiffTime -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay
class ( MonadTimer.MonadTimer m
, MonadMonotonicTime m
) => MonadTimer m where
registerDelay :: DiffTime -> m (TVar m Bool)
registerDelayCancellable :: DiffTime -> m (STM m TimeoutState, m ())
timeout :: DiffTime -> m a -> m (Maybe a)
defaultRegisterDelay :: forall m timeout.
( MonadFork m
, MonadMonotonicTime m
, MonadSTM m
)
=> NonStandard.NewTimeout m timeout
-> NonStandard.AwaitTimeout m timeout
-> DiffTime
-> m (TVar m Bool)
defaultRegisterDelay :: forall (m :: * -> *) timeout.
(MonadFork m, MonadMonotonicTime m, MonadSTM m) =>
NewTimeout m timeout
-> AwaitTimeout m timeout -> DiffTime -> m (TVar m Bool)
defaultRegisterDelay NewTimeout m timeout
newTimeout AwaitTimeout m timeout
awaitTimeout DiffTime
d = do
Time
c <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
TVar m Bool
v <- STM m (TVar m Bool) -> m (TVar m Bool)
forall a. (?callStack::CallStack) => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m (TVar m Bool) -> m (TVar m Bool))
-> STM m (TVar m Bool) -> m (TVar m Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> STM m (TVar m Bool)
forall a. a -> STM m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar Bool
False
ThreadId m
tid <- m () -> m (ThreadId m)
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO (m () -> m (ThreadId m)) -> m () -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ TVar m Bool -> Time -> Time -> m ()
go TVar m Bool
v Time
c (DiffTime
d DiffTime -> Time -> Time
`addTime` Time
c)
ThreadId m -> String -> m ()
forall (m :: * -> *). MonadThread m => ThreadId m -> String -> m ()
labelThread ThreadId m
tid String
"delay-thread"
TVar m Bool -> m (TVar m Bool)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TVar m Bool
v
where
maxDelay :: DiffTime
maxDelay :: DiffTime
maxDelay = Int -> DiffTime
microsecondsAsIntToDiffTime Int
forall a. Bounded a => a
maxBound
go :: TVar m Bool -> Time -> Time -> m ()
go :: TVar m Bool -> Time -> Time -> m ()
go TVar m Bool
v Time
c Time
u | Time
u Time -> Time -> DiffTime
`diffTime` Time
c DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
maxDelay = do
Bool
_ <- NewTimeout m timeout
newTimeout Int
forall a. Bounded a => a
maxBound m timeout -> (timeout -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM m Bool -> m Bool
forall a. (?callStack::CallStack) => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool)
-> AwaitTimeout m timeout -> timeout -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AwaitTimeout m timeout
awaitTimeout
Time
c' <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
TVar m Bool -> Time -> Time -> m ()
go TVar m Bool
v Time
c' Time
u
go TVar m Bool
v Time
c Time
u = do
timeout
t <- NewTimeout m timeout
newTimeout (DiffTime -> Int
diffTimeToMicrosecondsAsInt (DiffTime -> Int) -> DiffTime -> Int
forall a b. (a -> b) -> a -> b
$ Time
u Time -> Time -> DiffTime
`diffTime` Time
c)
STM m () -> m ()
forall a. (?callStack::CallStack) => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Bool
_ <- AwaitTimeout m timeout
awaitTimeout timeout
t
TVar m Bool -> Bool -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
v Bool
True
defaultRegisterDelayCancellable :: forall m timeout.
( MonadFork m
, MonadMonotonicTime m
, MonadSTM m
)
=> NonStandard.NewTimeout m timeout
-> NonStandard.ReadTimeout m timeout
-> NonStandard.CancelTimeout m timeout
-> NonStandard.AwaitTimeout m timeout
-> DiffTime
-> m (STM m TimeoutState, m ())
defaultRegisterDelayCancellable :: forall (m :: * -> *) timeout.
(MonadFork m, MonadMonotonicTime m, MonadSTM m) =>
NewTimeout m timeout
-> ReadTimeout m timeout
-> CancelTimeout m timeout
-> AwaitTimeout m timeout
-> DiffTime
-> m (STM m TimeoutState, m ())
defaultRegisterDelayCancellable NewTimeout m timeout
newTimeout ReadTimeout m timeout
readTimeout CancelTimeout m timeout
cancelTimeout AwaitTimeout m timeout
_awaitTimeout DiffTime
d | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= DiffTime
maxDelay = do
timeout
t <- NewTimeout m timeout
newTimeout (DiffTime -> Int
diffTimeToMicrosecondsAsInt DiffTime
d)
(STM m TimeoutState, m ()) -> m (STM m TimeoutState, m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReadTimeout m timeout
readTimeout timeout
t, CancelTimeout m timeout
cancelTimeout timeout
t)
where
maxDelay :: DiffTime
maxDelay :: DiffTime
maxDelay = Int -> DiffTime
microsecondsAsIntToDiffTime Int
forall a. Bounded a => a
maxBound
defaultRegisterDelayCancellable NewTimeout m timeout
newTimeout ReadTimeout m timeout
_readTimeout CancelTimeout m timeout
_cancelTimeout AwaitTimeout m timeout
awaitTimeout DiffTime
d = do
Time
c <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
TVar m TimeoutState
v <- TimeoutState -> m (TVar m TimeoutState)
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO TimeoutState
TimeoutPending
ThreadId m
tid <- m () -> m (ThreadId m)
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO (m () -> m (ThreadId m)) -> m () -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ TVar m TimeoutState -> Time -> Time -> m ()
go TVar m TimeoutState
v Time
c (DiffTime
d DiffTime -> Time -> Time
`addTime` Time
c)
ThreadId m -> String -> m ()
forall (m :: * -> *). MonadThread m => ThreadId m -> String -> m ()
labelThread ThreadId m
tid String
"delay-thread"
let cancel :: m ()
cancel = STM m () -> m ()
forall a. (?callStack::CallStack) => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m TimeoutState -> STM m TimeoutState
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m TimeoutState
v STM m TimeoutState -> (TimeoutState -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
TimeoutState
TimeoutCancelled -> () -> STM m ()
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TimeoutState
TimeoutFired -> () -> STM m ()
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TimeoutState
TimeoutPending -> TVar m TimeoutState -> TimeoutState -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m TimeoutState
v TimeoutState
TimeoutCancelled
(STM m TimeoutState, m ()) -> m (STM m TimeoutState, m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar m TimeoutState -> STM m TimeoutState
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m TimeoutState
v, m ()
cancel)
where
maxDelay :: DiffTime
maxDelay :: DiffTime
maxDelay = Int -> DiffTime
microsecondsAsIntToDiffTime Int
forall a. Bounded a => a
maxBound
go :: TVar m TimeoutState
-> Time
-> Time
-> m ()
go :: TVar m TimeoutState -> Time -> Time -> m ()
go TVar m TimeoutState
v Time
c Time
u | Time
u Time -> Time -> DiffTime
`diffTime` Time
c DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
maxDelay = do
timeout
t <- NewTimeout m timeout
newTimeout Int
forall a. Bounded a => a
maxBound
TimeoutState
ts <- STM m TimeoutState -> m TimeoutState
forall a. (?callStack::CallStack) => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m TimeoutState -> m TimeoutState)
-> STM m TimeoutState -> m TimeoutState
forall a b. (a -> b) -> a -> b
$ do
(TVar m TimeoutState -> STM m TimeoutState
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m TimeoutState
v STM m TimeoutState
-> (TimeoutState -> STM m TimeoutState) -> STM m TimeoutState
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
a :: TimeoutState
a@TimeoutState
TimeoutCancelled -> TimeoutState -> STM m TimeoutState
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return TimeoutState
a
TimeoutState
TimeoutFired -> String -> STM m TimeoutState
forall a. (?callStack::CallStack) => String -> a
error String
"registerDelayCancellable: invariant violation!"
TimeoutState
TimeoutPending -> STM m TimeoutState
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry)
STM m TimeoutState -> STM m TimeoutState -> STM m TimeoutState
forall a. STM m a -> STM m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse`
(AwaitTimeout m timeout
awaitTimeout timeout
t STM m Bool -> TimeoutState -> STM m TimeoutState
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TimeoutState
TimeoutPending)
case TimeoutState
ts of
TimeoutState
TimeoutPending -> do
Time
c' <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
TVar m TimeoutState -> Time -> Time -> m ()
go TVar m TimeoutState
v Time
c' Time
u
TimeoutState
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go TVar m TimeoutState
v Time
c Time
u = do
timeout
t <- NewTimeout m timeout
newTimeout (DiffTime -> Int
diffTimeToMicrosecondsAsInt (DiffTime -> Int) -> DiffTime -> Int
forall a b. (a -> b) -> a -> b
$ Time
u Time -> Time -> DiffTime
`diffTime` Time
c)
STM m () -> m ()
forall a. (?callStack::CallStack) => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
TimeoutState
ts <- (TVar m TimeoutState -> STM m TimeoutState
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m TimeoutState
v STM m TimeoutState
-> (TimeoutState -> STM m TimeoutState) -> STM m TimeoutState
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
a :: TimeoutState
a@TimeoutState
TimeoutCancelled -> TimeoutState -> STM m TimeoutState
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return TimeoutState
a
TimeoutState
TimeoutFired -> String -> STM m TimeoutState
forall a. (?callStack::CallStack) => String -> a
error String
"registerDelayCancellable: invariant violation!"
TimeoutState
TimeoutPending -> STM m TimeoutState
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry)
STM m TimeoutState -> STM m TimeoutState -> STM m TimeoutState
forall a. STM m a -> STM m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse`
(AwaitTimeout m timeout
awaitTimeout timeout
t STM m Bool -> TimeoutState -> STM m TimeoutState
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TimeoutState
TimeoutFired)
case TimeoutState
ts of
TimeoutState
TimeoutFired -> TVar m TimeoutState -> TimeoutState -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m TimeoutState
v TimeoutState
TimeoutFired
TimeoutState
_ -> () -> STM m ()
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance MonadTimer IO where
registerDelay :: DiffTime -> IO (TVar IO Bool)
registerDelay DiffTime
d
| DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= DiffTime
maxDelay =
Int -> IO (TVar IO Bool)
forall (m :: * -> *). MonadTimer m => Int -> m (TVar m Bool)
MonadTimer.registerDelay (DiffTime -> Int
diffTimeToMicrosecondsAsInt DiffTime
d)
| Bool
otherwise =
NewTimeout IO Timeout
-> AwaitTimeout IO Timeout -> DiffTime -> IO (TVar IO Bool)
forall (m :: * -> *) timeout.
(MonadFork m, MonadMonotonicTime m, MonadSTM m) =>
NewTimeout m timeout
-> AwaitTimeout m timeout -> DiffTime -> m (TVar m Bool)
defaultRegisterDelay
NewTimeout IO Timeout
NonStandard.newTimeout
AwaitTimeout IO Timeout
NonStandard.awaitTimeout
DiffTime
d
where
maxDelay :: DiffTime
maxDelay :: DiffTime
maxDelay = Int -> DiffTime
microsecondsAsIntToDiffTime Int
forall a. Bounded a => a
maxBound
registerDelayCancellable :: DiffTime -> IO (STM IO TimeoutState, IO ())
registerDelayCancellable =
NewTimeout IO Timeout
-> ReadTimeout IO Timeout
-> CancelTimeout IO Timeout
-> AwaitTimeout IO Timeout
-> DiffTime
-> IO (STM IO TimeoutState, IO ())
forall (m :: * -> *) timeout.
(MonadFork m, MonadMonotonicTime m, MonadSTM m) =>
NewTimeout m timeout
-> ReadTimeout m timeout
-> CancelTimeout m timeout
-> AwaitTimeout m timeout
-> DiffTime
-> m (STM m TimeoutState, m ())
defaultRegisterDelayCancellable
NewTimeout IO Timeout
NonStandard.newTimeout
ReadTimeout IO Timeout
NonStandard.readTimeout
CancelTimeout IO Timeout
NonStandard.cancelTimeout
AwaitTimeout IO Timeout
NonStandard.awaitTimeout
timeout :: forall a. DiffTime -> IO a -> IO (Maybe a)
timeout = Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
forall (m :: * -> *) a. MonadTimer m => Int -> m a -> m (Maybe a)
MonadTimer.timeout (Int -> IO a -> IO (Maybe a))
-> (DiffTime -> Int) -> DiffTime -> IO a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Int
diffTimeToMicrosecondsAsInt
instance MonadTimer m => MonadTimer (ReaderT r m) where
registerDelay :: DiffTime -> 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))
-> (DiffTime -> m (TVar m Bool))
-> DiffTime
-> ReaderT r 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
-> ReaderT r m (STM (ReaderT r m) TimeoutState, ReaderT r m ())
registerDelayCancellable = ((STM m TimeoutState, m ())
-> (ReaderT r (STM m) TimeoutState, ReaderT r m ()))
-> ReaderT r m (STM m TimeoutState, m ())
-> ReaderT r m (ReaderT r (STM m) TimeoutState, ReaderT r m ())
forall a b. (a -> b) -> ReaderT r m a -> ReaderT r m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((STM m TimeoutState -> ReaderT r (STM m) TimeoutState)
-> (m () -> ReaderT r m ())
-> (STM m TimeoutState, m ())
-> (ReaderT r (STM m) TimeoutState, ReaderT r 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 -> ReaderT r (STM m) TimeoutState
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 ()
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) (ReaderT r m (STM m TimeoutState, m ())
-> ReaderT r m (ReaderT r (STM m) TimeoutState, ReaderT r m ()))
-> (DiffTime -> ReaderT r m (STM m TimeoutState, m ()))
-> DiffTime
-> ReaderT r m (ReaderT r (STM m) TimeoutState, ReaderT r m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (STM m TimeoutState, m ())
-> ReaderT r m (STM m TimeoutState, 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 (STM m TimeoutState, m ())
-> ReaderT r m (STM m TimeoutState, m ()))
-> (DiffTime -> m (STM m TimeoutState, m ()))
-> DiffTime
-> ReaderT r 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 -> ReaderT r m a -> ReaderT r m (Maybe a)
timeout DiffTime
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 -> DiffTime -> m a -> m (Maybe a)
forall a. DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
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)