{-# 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 (..), runReaderT, 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