{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Pantry.Internal.Companion
( withCompanion
, onCompanionDone
, Companion
, Delay
, StopCompanion
) where
import RIO
type Companion m = Delay -> m ()
type Delay = forall mio. MonadIO mio => Int -> mio ()
type StopCompanion m = m ()
onCompanionDone
:: MonadUnliftIO m
=> m ()
-> m ()
-> m ()
onCompanionDone :: m () -> m () -> m ()
onCompanionDone m ()
theDelay m ()
theAction =
m ()
theDelay m () -> (CompanionDone -> m ()) -> m ()
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
`withException` \CompanionDone
CompanionDone -> m ()
theAction
data CompanionDone = CompanionDone
deriving (Int -> CompanionDone -> ShowS
[CompanionDone] -> ShowS
CompanionDone -> String
(Int -> CompanionDone -> ShowS)
-> (CompanionDone -> String)
-> ([CompanionDone] -> ShowS)
-> Show CompanionDone
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompanionDone] -> ShowS
$cshowList :: [CompanionDone] -> ShowS
show :: CompanionDone -> String
$cshow :: CompanionDone -> String
showsPrec :: Int -> CompanionDone -> ShowS
$cshowsPrec :: Int -> CompanionDone -> ShowS
Show, Typeable)
instance Exception CompanionDone
withCompanion
:: forall m a. MonadUnliftIO m
=> Companion m
-> (StopCompanion m -> m a)
-> m a
withCompanion :: Companion m -> (StopCompanion m -> m a) -> m a
withCompanion Companion m
companion StopCompanion m -> m a
inner = do
TVar Bool
shouldStopVar <- Bool -> m (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
False
let
stopCompanion :: StopCompanion m
stopCompanion = STM () -> StopCompanion m
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> StopCompanion m) -> STM () -> StopCompanion m
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
shouldStopVar Bool
True
delay :: Delay
delay :: Int -> mio ()
delay Int
usec = do
TVar Bool
delayDoneVar <- Int -> mio (TVar Bool)
forall (m :: * -> *). MonadIO m => Int -> m (TVar Bool)
registerDelay Int
usec
mio (mio ()) -> mio ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (mio (mio ()) -> mio ()) -> mio (mio ()) -> mio ()
forall a b. (a -> b) -> a -> b
$ STM (mio ()) -> mio (mio ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (mio ()) -> mio (mio ())) -> STM (mio ()) -> mio (mio ())
forall a b. (a -> b) -> a -> b
$
(() -> mio ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () mio () -> STM () -> STM (mio ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
delayDoneVar STM Bool -> (Bool -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM ()
checkSTM)) STM (mio ()) -> STM (mio ()) -> STM (mio ())
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(CompanionDone -> mio ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CompanionDone
CompanionDone mio () -> STM () -> STM (mio ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
shouldStopVar STM Bool -> (Bool -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM ()
checkSTM))
Concurrently m a -> m a
forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently (Concurrently m a -> m a) -> Concurrently m a -> m a
forall a b. (a -> b) -> a -> b
$
StopCompanion m -> Concurrently m ()
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (Companion m
companion Delay
delay StopCompanion m
-> (CompanionDone -> StopCompanion m) -> StopCompanion m
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \CompanionDone
CompanionDone -> () -> StopCompanion m
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Concurrently m () -> Concurrently m a -> Concurrently m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
m a -> Concurrently m a
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (StopCompanion m -> m a
inner StopCompanion m
stopCompanion m a -> StopCompanion m -> m a
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` StopCompanion m
stopCompanion)