{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Monad.Class.MonadThrow
( MonadThrow (..)
, MonadCatch (..)
, MonadMask (..)
, MonadMaskingState (..)
, MonadEvaluate (..)
, MaskingState (..)
, Exception (..)
, SomeException
, ExitCase (..)
, Handler (..)
, catches
) where
import Control.Exception (Exception (..), MaskingState, SomeException)
import qualified Control.Exception as IO
import Control.Monad (liftM)
import Control.Monad.Reader (ReaderT (..), lift)
import Control.Monad.STM (STM)
import qualified Control.Monad.STM as STM
class Monad m => MonadThrow m where
{-# MINIMAL throwIO #-}
throwIO :: Exception e => e -> m a
bracket :: m a -> (a -> m b) -> (a -> m c) -> m c
bracket_ :: m a -> m b -> m c -> m c
finally :: m a -> m b -> m a
default bracket :: MonadCatch m => m a -> (a -> m b) -> (a -> m c) -> m c
bracket m a
before a -> m b
after =
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
m a
before
(\a
a ExitCase c
_exitCase -> a -> m b
after a
a)
bracket_ m a
before m b
after m c
thing = forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m a
before (forall a b. a -> b -> a
const m b
after) (forall a b. a -> b -> a
const m c
thing)
m a
a `finally` m b
sequel =
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> m b -> m c -> m c
bracket_ (forall (m :: * -> *) a. Monad m => a -> m a
return ()) m b
sequel m a
a
class MonadThrow m => MonadCatch m where
{-# MINIMAL catch #-}
catch :: Exception e => m a -> (e -> m a) -> m a
catchJust :: Exception e => (e -> Maybe b) -> m a -> (b -> m a) -> m a
try :: Exception e => m a -> m (Either e a)
tryJust :: Exception e => (e -> Maybe b) -> m a -> m (Either b a)
handle :: Exception e => (e -> m a) -> m a -> m a
handleJust :: Exception e => (e -> Maybe b) -> (b -> m a) -> m a -> m a
onException :: m a -> m b -> m a
bracketOnError :: m a -> (a -> m b) -> (a -> m c) -> m c
generalBracket :: m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
default generalBracket
:: MonadMask m
=> m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
catchJust e -> Maybe b
p m a
a b -> m a
handler =
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch m a
a e -> m a
handler'
where
handler' :: e -> m a
handler' e
e = case e -> Maybe b
p e
e of
Maybe b
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e
Just b
b -> b -> m a
handler b
b
try m a
a = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m a
a) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
tryJust e -> Maybe b
p m a
a = do
Either e a
r <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m a
a
case Either e a
r of
Right a
v -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
v)
Left e
e -> case e -> Maybe b
p e
e of
Maybe b
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e
Just b
b -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left b
b)
handle = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
handleJust e -> Maybe b
p = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust e -> Maybe b
p)
onException m a
action m b
what =
m a
action forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> do
b
_ <- m b
what
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (SomeException
e :: SomeException)
bracketOnError m a
acquire a -> m b
release = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
m a
acquire
(\a
a ExitCase c
exitCase -> case ExitCase c
exitCase of
ExitCaseSuccess c
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitCase c
_ -> do
b
_ <- a -> m b
release a
a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
generalBracket m a
acquire a -> ExitCase b -> m c
release a -> m b
use =
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
unmasked -> do
a
resource <- m a
acquire
b
b <- forall a. m a -> m a
unmasked (a -> m b
use a
resource) forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> do
c
_ <- a -> ExitCase b -> m c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
c
c <- a -> ExitCase b -> m c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)
data Handler m a = forall e. Exception e => Handler (e -> m a)
deriving instance (Functor m) => Functor (Handler m)
catches :: forall m a. MonadCatch m
=> m a -> [Handler m a] -> m a
catches :: forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
catches m a
ma [Handler m a]
handlers = m a
ma forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall (m :: * -> *) a.
MonadCatch m =>
[Handler m a] -> SomeException -> m a
catchesHandler [Handler m a]
handlers
{-# SPECIALISE catches :: IO a -> [Handler IO a] -> IO a #-}
catchesHandler :: MonadCatch m
=> [Handler m a]
-> SomeException
-> m a
catchesHandler :: forall (m :: * -> *) a.
MonadCatch m =>
[Handler m a] -> SomeException -> m a
catchesHandler [Handler m a]
handlers SomeException
e = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Handler m a -> m a -> m a
tryHandler (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e) [Handler m a]
handlers
where tryHandler :: Handler m a -> m a -> m a
tryHandler (Handler e -> m a
handler) m a
res
= case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just e
e' -> e -> m a
handler e
e'
Maybe e
Nothing -> m a
res
{-# SPECIALISE catchesHandler :: [Handler IO a] -> SomeException -> IO a #-}
data ExitCase a
= ExitCaseSuccess a
| ExitCaseException SomeException
| ExitCaseAbort
deriving (Int -> ExitCase a -> ShowS
forall a. Show a => Int -> ExitCase a -> ShowS
forall a. Show a => [ExitCase a] -> ShowS
forall a. Show a => ExitCase a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExitCase a] -> ShowS
$cshowList :: forall a. Show a => [ExitCase a] -> ShowS
show :: ExitCase a -> String
$cshow :: forall a. Show a => ExitCase a -> String
showsPrec :: Int -> ExitCase a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ExitCase a -> ShowS
Show, forall a b. a -> ExitCase b -> ExitCase a
forall a b. (a -> b) -> ExitCase a -> ExitCase b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ExitCase b -> ExitCase a
$c<$ :: forall a b. a -> ExitCase b -> ExitCase a
fmap :: forall a b. (a -> b) -> ExitCase a -> ExitCase b
$cfmap :: forall a b. (a -> b) -> ExitCase a -> ExitCase b
Functor)
class MonadCatch m => MonadMask m where
{-# MINIMAL mask, uninterruptibleMask #-}
mask, uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b
mask_, uninterruptibleMask_ :: m a -> m a
mask_ m a
action = forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
_ -> m a
action
uninterruptibleMask_ m a
action = forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
_ -> m a
action
class MonadMask m => MonadMaskingState m where
{-# MINIMAL getMaskingState, interruptible #-}
getMaskingState :: m MaskingState
interruptible :: m a -> m a
allowInterrupt :: m ()
allowInterrupt = forall (m :: * -> *) a. MonadMaskingState m => m a -> m a
interruptible (forall (m :: * -> *) a. Monad m => a -> m a
return ())
class MonadThrow m => MonadEvaluate m where
evaluate :: a -> m a
instance MonadThrow IO where
throwIO :: forall e a. Exception e => e -> IO a
throwIO = forall e a. Exception e => e -> IO a
IO.throwIO
bracket :: forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
IO.bracket
bracket_ :: forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ = forall a b c. IO a -> IO b -> IO c -> IO c
IO.bracket_
finally :: forall a b. IO a -> IO b -> IO a
finally = forall a b. IO a -> IO b -> IO a
IO.finally
instance MonadCatch IO where
catch :: forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
IO.catch
catchJust :: forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust = forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
IO.catchJust
try :: forall e a. Exception e => IO a -> IO (Either e a)
try = forall e a. Exception e => IO a -> IO (Either e a)
IO.try
tryJust :: forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust = forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
IO.tryJust
handle :: forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
IO.handle
handleJust :: forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust = forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
IO.handleJust
onException :: forall a b. IO a -> IO b -> IO a
onException = forall a b. IO a -> IO b -> IO a
IO.onException
bracketOnError :: forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
IO.bracketOnError
instance MonadMask IO where
mask :: forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
IO.mask
mask_ :: forall a. IO a -> IO a
mask_ = forall a. IO a -> IO a
IO.mask_
uninterruptibleMask :: forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
IO.uninterruptibleMask
uninterruptibleMask_ :: forall a. IO a -> IO a
uninterruptibleMask_ = forall a. IO a -> IO a
IO.uninterruptibleMask_
instance MonadMaskingState IO where
getMaskingState :: IO MaskingState
getMaskingState = IO MaskingState
IO.getMaskingState
interruptible :: forall a. IO a -> IO a
interruptible = forall a. IO a -> IO a
IO.interruptible
allowInterrupt :: IO ()
allowInterrupt = IO ()
IO.allowInterrupt
instance MonadEvaluate IO where
evaluate :: forall a. a -> IO a
evaluate = forall a. a -> IO a
IO.evaluate
instance MonadThrow STM where
throwIO :: forall e a. Exception e => e -> STM a
throwIO = forall e a. Exception e => e -> STM a
STM.throwSTM
instance MonadCatch STM where
catch :: forall e a. Exception e => STM a -> (e -> STM a) -> STM a
catch = forall e a. Exception e => STM a -> (e -> STM a) -> STM a
STM.catchSTM
generalBracket :: forall a b c.
STM a -> (a -> ExitCase b -> STM c) -> (a -> STM b) -> STM (b, c)
generalBracket STM a
acquire a -> ExitCase b -> STM c
release a -> STM b
use = do
a
resource <- STM a
acquire
b
b <- a -> STM b
use a
resource forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> do
c
_ <- a -> ExitCase b -> STM c
release a
resource (forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
c
c <- a -> ExitCase b -> STM c
release a
resource (forall a. a -> ExitCase a
ExitCaseSuccess b
b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)
instance MonadThrow m => MonadThrow (ReaderT r m) where
throwIO :: forall e a. Exception e => e -> ReaderT r m a
throwIO = 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 :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO
bracket :: forall a b c.
ReaderT r m a
-> (a -> ReaderT r m b) -> (a -> ReaderT r m c) -> ReaderT r m c
bracket ReaderT r m a
acquire a -> ReaderT r m b
release a -> ReaderT r m c
use = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
env ->
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
( forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
acquire r
env)
(\a
a -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m b
release a
a) r
env)
(\a
a -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m c
use a
a) r
env)
instance MonadCatch m => MonadCatch (ReaderT r m) where
catch :: forall e a.
Exception e =>
ReaderT r m a -> (e -> ReaderT r m a) -> ReaderT r m a
catch ReaderT r m a
act e -> ReaderT r m a
handler = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
env ->
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
( forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
act r
env)
(\e
e -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (e -> ReaderT r m a
handler e
e) r
env)
generalBracket :: forall a b c.
ReaderT r m a
-> (a -> ExitCase b -> ReaderT r m c)
-> (a -> ReaderT r m b)
-> ReaderT r m (b, c)
generalBracket ReaderT r m a
acquire a -> ExitCase b -> ReaderT r m c
release a -> ReaderT r m b
use = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
env ->
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
( forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
acquire r
env)
(\a
a ExitCase b
e -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ExitCase b -> ReaderT r m c
release a
a ExitCase b
e) r
env)
(\a
a -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m b
use a
a) r
env)
instance MonadMask m => MonadMask (ReaderT r m) where
mask :: forall b.
((forall a. ReaderT r m a -> ReaderT r m a) -> ReaderT r m b)
-> ReaderT r m b
mask (forall a. ReaderT r m a -> ReaderT r m a) -> ReaderT r m b
a = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
e -> forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ((forall a. ReaderT r m a -> ReaderT r m a) -> ReaderT r m b
a forall a b. (a -> b) -> a -> b
$ forall a e. (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q forall a. m a -> m a
u) r
e
where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q :: forall a e. (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q m a -> m a
u (ReaderT e -> m a
b) = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (m a -> m a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
b)
uninterruptibleMask :: forall b.
((forall a. ReaderT r m a -> ReaderT r m a) -> ReaderT r m b)
-> ReaderT r m b
uninterruptibleMask (forall a. ReaderT r m a -> ReaderT r m a) -> ReaderT r m b
a =
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
e -> forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ((forall a. ReaderT r m a -> ReaderT r m a) -> ReaderT r m b
a forall a b. (a -> b) -> a -> b
$ forall a e. (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q forall a. m a -> m a
u) r
e
where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q :: forall a e. (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q m a -> m a
u (ReaderT e -> m a
b) = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (m a -> m a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
b)
instance MonadEvaluate m => MonadEvaluate (ReaderT r m) where
evaluate :: forall a. a -> ReaderT r m a
evaluate = 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 :: * -> *) a. MonadEvaluate m => a -> m a
evaluate