{-# LANGUAGE DefaultSignatures         #-}
{-# LANGUAGE DeriveFunctor             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE StandaloneDeriving        #-}
{-# LANGUAGE TypeFamilies              #-}

module Control.Monad.Class.MonadThrow
  ( MonadThrow (..)
  , MonadCatch (..)
  , MonadMask (..)
  , MonadMaskingState (..)
  , MonadEvaluate (..)
  , MaskingState (..)
  , Exception (..)
  , SomeException
  , ExitCase (..)
  , Handler (..)
  , catches
    -- * Deprecated interfaces
  , throwM
  ) where

import           Control.Exception (Exception (..), MaskingState, SomeException)
import qualified Control.Exception as IO
import           Control.Monad (liftM)
import           Control.Monad.Except (ExceptT (..), lift, runExceptT)
import           Control.Monad.Reader (ReaderT (..), runReaderT)
import           Control.Monad.STM (STM)
import qualified Control.Monad.STM as STM

-- | Throwing exceptions, and resource handling in the presence of exceptions.
--
-- Does not include the ability to respond to exceptions.
--
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 =
    ((c, b) -> c) -> m (c, b) -> m c
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (c, b) -> c
forall a b. (a, b) -> a
fst (m (c, b) -> m c) -> ((a -> m c) -> m (c, b)) -> (a -> m c) -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      m a -> (a -> ExitCase c -> m b) -> (a -> m c) -> m (c, b)
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 = m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m a
before (m b -> a -> m b
forall a b. a -> b -> a
const m b
after) (m c -> a -> m c
forall a b. a -> b -> a
const m c
thing)

  m a
a `finally` m b
sequel =
    m () -> m b -> m a -> m a
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> m b -> m c -> m c
bracket_ (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m b
sequel m a
a

throwM :: (MonadThrow m, Exception e) => e -> m a
throwM :: e -> m a
throwM = e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO
{-# DEPRECATED throwM "Use throwIO" #-}

-- | Catching exceptions.
--
-- Covers standard utilities to respond to exceptions.
--
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

  -- | General form of bracket
  --
  -- See <http://hackage.haskell.org/package/exceptions-0.10.0/docs/Control-Monad-Catch.html#v:generalBracket>
  -- for discussion and motivation.
  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 =
      m a -> (e -> m a) -> m a
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 -> e -> m a
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 = m (Either e a) -> (e -> m (Either e a)) -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (a -> Either e a
forall a b. b -> Either a b
Right (a -> Either e a) -> m a -> m (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m a
a) (Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> m (Either e a))
-> (e -> Either e a) -> e -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left)

  tryJust e -> Maybe b
p m a
a = do
    Either e a
r <- m a -> m (Either e a)
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 -> Either b a -> m (Either b a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either b a
forall a b. b -> Either a b
Right a
v)
      Left  e
e -> case e -> Maybe b
p e
e of
                   Maybe b
Nothing -> e -> m (Either b a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e
                   Just b
b  -> Either b a -> m (Either b a)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either b a
forall a b. a -> Either a b
Left b
b)

  handle       = (m a -> (e -> m a) -> m a) -> (e -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
  handleJust e -> Maybe b
p = (m a -> (b -> m a) -> m a) -> (b -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((e -> Maybe b) -> m a -> (b -> m a) -> m a
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 m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> do
              b
_ <- m b
what
              SomeException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (SomeException
e :: SomeException)

  bracketOnError m a
acquire a -> m b
release = ((c, ()) -> c) -> m (c, ()) -> m c
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (c, ()) -> c
forall a b. (a, b) -> a
fst (m (c, ()) -> m c)
-> ((a -> m c) -> m (c, ())) -> (a -> m c) -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> (a -> ExitCase c -> m ()) -> (a -> m c) -> m (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
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ExitCase c
_ -> do
        b
_ <- a -> m b
release a
a
        () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

  generalBracket m a
acquire a -> ExitCase b -> m c
release a -> m b
use =
    ((forall a. m a -> m a) -> m (b, c)) -> m (b, c)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (b, c)) -> m (b, c))
-> ((forall a. m a -> m a) -> m (b, c)) -> m (b, c)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
unmasked -> do
      a
resource <- m a
acquire
      b
b <- m b -> m b
forall a. m a -> m a
unmasked (a -> m b
use a
resource) m b -> (SomeException -> m b) -> m b
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 (SomeException -> ExitCase b
forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)
        SomeException -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
      c
c <- a -> ExitCase b -> m c
release a
resource (b -> ExitCase b
forall a. a -> ExitCase a
ExitCaseSuccess b
b)
      (b, c) -> m (b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)


-- | The default handler type for 'catches', whcih is a generalisation of
-- 'IO.Handler'.
--
data Handler m a = forall e. Exception e => Handler (e -> m a)

deriving instance (Functor m) => Functor (Handler m)

-- | Like 'catches' but for 'MonadCatch' rather than only 'IO'.
--
catches :: forall m a. MonadCatch m
         => m a -> [Handler m a] -> m a
catches :: m a -> [Handler m a] -> m a
catches m a
ma [Handler m a]
handlers = m a
ma m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` [Handler m a] -> SomeException -> m a
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 #-}

-- | Used in the default 'catches' implementation.
--
catchesHandler :: MonadCatch m
               => [Handler m a]
               -> SomeException
               -> m a
catchesHandler :: [Handler m a] -> SomeException -> m a
catchesHandler [Handler m a]
handlers SomeException
e = (Handler m a -> m a -> m a) -> m a -> [Handler m a] -> m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Handler m a -> m a -> m a
tryHandler (SomeException -> m a
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 SomeException -> Maybe e
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 #-}


-- | Used in 'generalBracket'
--
-- See @exceptions@ package for discussion and motivation.
data ExitCase a
  = ExitCaseSuccess a
  | ExitCaseException SomeException
  | ExitCaseAbort
  deriving (Int -> ExitCase a -> ShowS
[ExitCase a] -> ShowS
ExitCase a -> String
(Int -> ExitCase a -> ShowS)
-> (ExitCase a -> String)
-> ([ExitCase a] -> ShowS)
-> Show (ExitCase a)
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, a -> ExitCase b -> ExitCase a
(a -> b) -> ExitCase a -> ExitCase b
(forall a b. (a -> b) -> ExitCase a -> ExitCase b)
-> (forall a b. a -> ExitCase b -> ExitCase a) -> Functor ExitCase
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
<$ :: a -> ExitCase b -> ExitCase a
$c<$ :: forall a b. a -> ExitCase b -> ExitCase a
fmap :: (a -> b) -> ExitCase a -> ExitCase b
$cfmap :: forall a b. (a -> b) -> ExitCase a -> ExitCase b
Functor)

-- | Support for safely working in the presence of asynchronous exceptions.
--
-- This is typically not needed directly as the utilities in 'MonadThrow' and
-- 'MonadCatch' cover most use cases.
--
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 a. m a -> m a) -> m a) -> m a
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask                (((forall a. m a -> m a) -> m a) -> m a)
-> ((forall a. m a -> m a) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
_ -> m a
action
  uninterruptibleMask_ m a
action = ((forall a. m a -> m a) -> m a) -> m a
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
uninterruptibleMask (((forall a. m a -> m a) -> m a) -> m a)
-> ((forall a. m a -> m a) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
_ -> m a
action


class MonadMask m => MonadMaskingState m where
  getMaskingState :: m MaskingState

-- | Monads which can 'evaluate'.
--
class MonadThrow m => MonadEvaluate m where
    evaluate :: a -> m a

--
-- Instance for IO uses the existing base library implementations
--

instance MonadThrow IO where

  throwIO :: e -> IO a
throwIO  = e -> IO a
forall e a. Exception e => e -> IO a
IO.throwIO

  bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket  = IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
IO.bracket
  bracket_ :: IO a -> IO b -> IO c -> IO c
bracket_ = IO a -> IO b -> IO c -> IO c
forall a b c. IO a -> IO b -> IO c -> IO c
IO.bracket_
  finally :: IO a -> IO b -> IO a
finally  = IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
IO.finally


instance MonadCatch IO where

  catch :: IO a -> (e -> IO a) -> IO a
catch      = IO a -> (e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
IO.catch

  catchJust :: (e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust  = (e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
IO.catchJust
  try :: IO a -> IO (Either e a)
try        = IO a -> IO (Either e a)
forall e a. Exception e => IO a -> IO (Either e a)
IO.try
  tryJust :: (e -> Maybe b) -> IO a -> IO (Either b a)
tryJust    = (e -> Maybe b) -> IO a -> IO (Either b a)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
IO.tryJust
  handle :: (e -> IO a) -> IO a -> IO a
handle     = (e -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
IO.handle
  handleJust :: (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust = (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
IO.handleJust
  onException :: IO a -> IO b -> IO a
onException    = IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
IO.onException
  bracketOnError :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError = IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
IO.bracketOnError
  -- use default implementation of 'generalBracket' (base does not define one)


instance MonadMask IO where

  mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
mask  = ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
IO.mask
  mask_ :: IO a -> IO a
mask_ = IO a -> IO a
forall a. IO a -> IO a
IO.mask_

  uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask  = ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
IO.uninterruptibleMask
  uninterruptibleMask_ :: IO a -> IO a
uninterruptibleMask_ = IO a -> IO a
forall a. IO a -> IO a
IO.uninterruptibleMask_

instance MonadMaskingState IO where
  getMaskingState :: IO MaskingState
getMaskingState = IO MaskingState
IO.getMaskingState

instance MonadEvaluate IO where
  evaluate :: a -> IO a
evaluate = a -> IO a
forall a. a -> IO a
IO.evaluate

--
-- Instance for STM uses STM primitives and default implementations
--

instance MonadThrow STM where
  throwIO :: e -> STM a
throwIO = e -> STM a
forall e a. Exception e => e -> STM a
STM.throwSTM

instance MonadCatch STM where
  catch :: STM a -> (e -> STM a) -> STM a
catch  = STM a -> (e -> STM a) -> STM a
forall e a. Exception e => STM a -> (e -> STM a) -> STM a
STM.catchSTM

  generalBracket :: 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 STM b -> (SomeException -> STM b) -> STM b
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 (SomeException -> ExitCase b
forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)
      SomeException -> STM b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
    c
c <- a -> ExitCase b -> STM c
release a
resource (b -> ExitCase b
forall a. a -> ExitCase a
ExitCaseSuccess b
b)
    (b, c) -> STM (b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)


--
-- Instances for ReaderT
--

instance MonadThrow m => MonadThrow (ReaderT r m) where
  throwIO :: e -> ReaderT r m a
throwIO = m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT r m a) -> (e -> m a) -> e -> ReaderT r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO
  bracket :: 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 = (r -> m c) -> ReaderT r m c
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m c) -> ReaderT r m c) -> (r -> m c) -> ReaderT r m c
forall a b. (a -> b) -> a -> b
$ \r
env ->
    m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
      (      ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
acquire     r
env)
      (\a
a -> ReaderT r m b -> r -> m b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m b
release a
a) r
env)
      (\a
a -> ReaderT r m c -> r -> m c
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 :: 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 = (r -> m a) -> ReaderT r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m a) -> ReaderT r m a) -> (r -> m a) -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ \r
env ->
    m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
      (      ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
act         r
env)
      (\e
e -> ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (e -> ReaderT r m a
handler e
e) r
env)

  generalBracket :: 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 = (r -> m (b, c)) -> ReaderT r m (b, c)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m (b, c)) -> ReaderT r m (b, c))
-> (r -> m (b, c)) -> ReaderT r m (b, c)
forall a b. (a -> b) -> a -> b
$ \r
env ->
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
      (        ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
acquire       r
env)
      (\a
a ExitCase b
e -> ReaderT r m c -> r -> m c
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   -> ReaderT r m b -> r -> m b
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 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 = (r -> m b) -> ReaderT r m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m b) -> ReaderT r m b) -> (r -> m b) -> ReaderT r m b
forall a b. (a -> b) -> a -> b
$ \r
e -> ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m b) -> m b)
-> ((forall a. m a -> m a) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u -> ReaderT r m b -> r -> m b
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. ReaderT r m a -> ReaderT r m a) -> ReaderT r m b)
-> (forall a. ReaderT r m a -> ReaderT r m a) -> ReaderT r m b
forall a b. (a -> b) -> a -> b
$ (m a -> m a) -> ReaderT r m a -> ReaderT r m a
forall a e. (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q m a -> m a
forall a. m a -> m a
u) r
e
    where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a
          q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q m a -> m a
u (ReaderT e -> m a
b) = (e -> m a) -> ReaderT e m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (m a -> m a
u (m a -> m a) -> (e -> m a) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
b)
  uninterruptibleMask :: ((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 =
    (r -> m b) -> ReaderT r m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m b) -> ReaderT r m b) -> (r -> m b) -> ReaderT r m b
forall a b. (a -> b) -> a -> b
$ \r
e -> ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
uninterruptibleMask (((forall a. m a -> m a) -> m b) -> m b)
-> ((forall a. m a -> m a) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u -> ReaderT r m b -> r -> m b
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. ReaderT r m a -> ReaderT r m a) -> ReaderT r m b)
-> (forall a. ReaderT r m a -> ReaderT r m a) -> ReaderT r m b
forall a b. (a -> b) -> a -> b
$ (m a -> m a) -> ReaderT r m a -> ReaderT r m a
forall a e. (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q m a -> m a
forall a. m a -> m a
u) r
e
      where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a
            q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q m a -> m a
u (ReaderT e -> m a
b) = (e -> m a) -> ReaderT e m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (m a -> m a
u (m a -> m a) -> (e -> m a) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
b)

instance MonadEvaluate m => MonadEvaluate (ReaderT r m) where
  evaluate :: a -> ReaderT r m a
evaluate = m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT r m a) -> (a -> m a) -> a -> ReaderT r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate

--
-- Instances for ExceptT
--
-- These all follow the @exceptions@ package to the letter
--

instance MonadCatch m => MonadThrow (ExceptT e m) where
  throwIO :: e -> ExceptT e m a
throwIO = m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ExceptT e m a) -> (e -> m a) -> e -> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO

instance MonadCatch m => MonadCatch (ExceptT e m) where
  catch :: ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catch (ExceptT m (Either e a)
m) e -> ExceptT e m a
f = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> m (Either e a) -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$ m (Either e a) -> (e -> m (Either e a)) -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch m (Either e a)
m (ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e m a -> m (Either e a))
-> (e -> ExceptT e m a) -> e -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ExceptT e m a
f)

  generalBracket :: ExceptT e m a
-> (a -> ExitCase b -> ExceptT e m c)
-> (a -> ExceptT e m b)
-> ExceptT e m (b, c)
generalBracket ExceptT e m a
acquire a -> ExitCase b -> ExceptT e m c
release a -> ExceptT e m b
use = m (Either e (b, c)) -> ExceptT e m (b, c)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e (b, c)) -> ExceptT e m (b, c))
-> m (Either e (b, c)) -> ExceptT e m (b, c)
forall a b. (a -> b) -> a -> b
$ do
    (Either e b
eb, Either e c
ec) <- m (Either e a)
-> (Either e a -> ExitCase (Either e b) -> m (Either e c))
-> (Either e a -> m (Either e b))
-> m (Either e b, Either e c)
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
      (ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m a
acquire)
      (\Either e a
eresource ExitCase (Either e b)
exitCase -> case Either e a
eresource of
        Left e
e -> Either e c -> m (Either e c)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Either e c
forall a b. a -> Either a b
Left e
e) -- nothing to release, acquire didn't succeed
        Right a
resource -> case ExitCase (Either e b)
exitCase of
          ExitCaseSuccess (Right b
b) -> ExceptT e m c -> m (Either e c)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExitCase b -> ExceptT e m c
release a
resource (b -> ExitCase b
forall a. a -> ExitCase a
ExitCaseSuccess b
b))
          ExitCaseException SomeException
e       -> ExceptT e m c -> m (Either e c)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExitCase b -> ExceptT e m c
release a
resource (SomeException -> ExitCase b
forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e))
          ExitCase (Either e b)
_                         -> ExceptT e m c -> m (Either e c)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExitCase b -> ExceptT e m c
release a
resource ExitCase b
forall a. ExitCase a
ExitCaseAbort))
      ((e -> m (Either e b))
-> (a -> m (Either e b)) -> Either e a -> m (Either e b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either e b -> m (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b))
-> (e -> Either e b) -> e -> m (Either e b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e b
forall a b. a -> Either a b
Left) (ExceptT e m b -> m (Either e b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e m b -> m (Either e b))
-> (a -> ExceptT e m b) -> a -> m (Either e b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ExceptT e m b
use))
    Either e (b, c) -> m (Either e (b, c))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e (b, c) -> m (Either e (b, c)))
-> Either e (b, c) -> m (Either e (b, c))
forall a b. (a -> b) -> a -> b
$ do
      -- The order in which we perform those two 'Either' effects determines
      -- which error will win if they are both 'Left's. We want the error from
      -- 'release' to win.
      c
c <- Either e c
ec
      b
b <- Either e b
eb
      (b, c) -> Either e (b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)

instance MonadMask m => MonadMask (ExceptT e m) where
  mask :: ((forall a. ExceptT e m a -> ExceptT e m a) -> ExceptT e m b)
-> ExceptT e m b
mask (forall a. ExceptT e m a -> ExceptT e m a) -> ExceptT e m b
f = m (Either e b) -> ExceptT e m b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e b) -> ExceptT e m b)
-> m (Either e b) -> ExceptT e m b
forall a b. (a -> b) -> a -> b
$ ((forall a. m a -> m a) -> m (Either e b)) -> m (Either e b)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (Either e b)) -> m (Either e b))
-> ((forall a. m a -> m a) -> m (Either e b)) -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u -> ExceptT e m b -> m (Either e b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e m b -> m (Either e b))
-> ExceptT e m b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ (forall a. ExceptT e m a -> ExceptT e m a) -> ExceptT e m b
f ((m (Either e a) -> m (Either e a))
-> ExceptT e m a -> ExceptT e m a
forall a.
(m (Either e a) -> m (Either e a))
-> ExceptT e m a -> ExceptT e m a
q m (Either e a) -> m (Either e a)
forall a. m a -> m a
u)
    where
      q :: (m (Either e a) -> m (Either e a))
        -> ExceptT e m a -> ExceptT e m a
      q :: (m (Either e a) -> m (Either e a))
-> ExceptT e m a -> ExceptT e m a
q m (Either e a) -> m (Either e a)
u (ExceptT m (Either e a)
b) = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> m (Either e a)
u m (Either e a)
b)
  uninterruptibleMask :: ((forall a. ExceptT e m a -> ExceptT e m a) -> ExceptT e m b)
-> ExceptT e m b
uninterruptibleMask (forall a. ExceptT e m a -> ExceptT e m a) -> ExceptT e m b
f = m (Either e b) -> ExceptT e m b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e b) -> ExceptT e m b)
-> m (Either e b) -> ExceptT e m b
forall a b. (a -> b) -> a -> b
$ ((forall a. m a -> m a) -> m (Either e b)) -> m (Either e b)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
uninterruptibleMask (((forall a. m a -> m a) -> m (Either e b)) -> m (Either e b))
-> ((forall a. m a -> m a) -> m (Either e b)) -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u -> ExceptT e m b -> m (Either e b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e m b -> m (Either e b))
-> ExceptT e m b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ (forall a. ExceptT e m a -> ExceptT e m a) -> ExceptT e m b
f ((m (Either e a) -> m (Either e a))
-> ExceptT e m a -> ExceptT e m a
forall a.
(m (Either e a) -> m (Either e a))
-> ExceptT e m a -> ExceptT e m a
q m (Either e a) -> m (Either e a)
forall a. m a -> m a
u)
    where
      q :: (m (Either e a) -> m (Either e a))
        -> ExceptT e m a -> ExceptT e m a
      q :: (m (Either e a) -> m (Either e a))
-> ExceptT e m a -> ExceptT e m a
q m (Either e a) -> m (Either e a)
u (ExceptT m (Either e a)
b) = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> m (Either e a)
u m (Either e a)
b)