module Database.PostgreSQL.Consumers.Utils (
finalize
, ThrownFrom(..)
, stopExecution
, forkP
, gforkP
) where
import Control.Concurrent.Lifted
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Trans.Control
import Data.Typeable
import Prelude
import qualified Control.Concurrent.Thread.Group.Lifted as TG
import qualified Control.Concurrent.Thread.Lifted as T
import qualified Control.Exception.Lifted as E
finalize :: (MonadMask m, MonadBase IO m) => m (m ()) -> m a -> m a
finalize :: forall (m :: * -> *) a.
(MonadMask m, MonadBase IO m) =>
m (m ()) -> m a -> m a
finalize m (m ())
m m a
action = do
MVar (m ())
finalizer <- forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (m :: * -> *) a. MonadBase IO m => MVar a -> m (Maybe a)
tryTakeMVar MVar (m ())
finalizer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar (m ())
finalizer forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (m ())
m
m a
action
data StopExecution = StopExecution
deriving (Int -> StopExecution -> ShowS
[StopExecution] -> ShowS
StopExecution -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StopExecution] -> ShowS
$cshowList :: [StopExecution] -> ShowS
show :: StopExecution -> String
$cshow :: StopExecution -> String
showsPrec :: Int -> StopExecution -> ShowS
$cshowsPrec :: Int -> StopExecution -> ShowS
Show, Typeable)
instance Exception StopExecution
data ThrownFrom = ThrownFrom String SomeException
deriving (Int -> ThrownFrom -> ShowS
[ThrownFrom] -> ShowS
ThrownFrom -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThrownFrom] -> ShowS
$cshowList :: [ThrownFrom] -> ShowS
show :: ThrownFrom -> String
$cshow :: ThrownFrom -> String
showsPrec :: Int -> ThrownFrom -> ShowS
$cshowsPrec :: Int -> ThrownFrom -> ShowS
Show, Typeable)
instance Exception ThrownFrom
stopExecution :: MonadBase IO m => ThreadId -> m ()
stopExecution :: forall (m :: * -> *). MonadBase IO m => ThreadId -> m ()
stopExecution = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e.
(MonadBase IO m, Exception e) =>
ThreadId -> e -> m ()
throwTo StopExecution
StopExecution
forkP :: MonadBaseControl IO m => String -> m () -> m ThreadId
forkP :: forall (m :: * -> *).
MonadBaseControl IO m =>
String -> m () -> m ThreadId
forkP = forall (m :: * -> *) a.
MonadBaseControl IO m =>
(m () -> m a) -> String -> m () -> m a
forkImpl forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork
gforkP :: MonadBaseControl IO m
=> TG.ThreadGroup
-> String
-> m ()
-> m (ThreadId, m (T.Result ()))
gforkP :: forall (m :: * -> *).
MonadBaseControl IO m =>
ThreadGroup -> String -> m () -> m (ThreadId, m (Result ()))
gforkP = forall (m :: * -> *) a.
MonadBaseControl IO m =>
(m () -> m a) -> String -> m () -> m a
forkImpl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadBaseControl IO m =>
ThreadGroup -> m a -> m (ThreadId, m (Result a))
TG.fork
forkImpl :: MonadBaseControl IO m
=> (m () -> m a)
-> String
-> m ()
-> m a
forkImpl :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
(m () -> m a) -> String -> m () -> m a
forkImpl m () -> m a
ffork String
tname m ()
m = forall (m :: * -> *) b.
MonadBaseControl IO m =>
((forall a. m a -> m a) -> m b) -> m b
E.mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
release -> do
ThreadId
parent <- forall (m :: * -> *). MonadBase IO m => m ThreadId
myThreadId
m () -> m a
ffork forall a b. (a -> b) -> a -> b
$ forall a. m a -> m a
release m ()
m forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> [Handler m a] -> m a
`E.catches` [
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
E.Handler forall a b. (a -> b) -> a -> b
$ \StopExecution
StopExecution -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
, forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
E.Handler forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) e.
(MonadBase IO m, Exception e) =>
ThreadId -> e -> m ()
throwTo ThreadId
parent forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SomeException -> ThrownFrom
ThrownFrom String
tname)
]