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

-- | A generalisation of
-- <https://hackage.haskell.org/package/base/docs/Control-Exception.html Control.Exception>
-- API to both 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.
--
module Control.Monad.Class.MonadThrow
  ( MonadThrow (..)
  , MonadCatch (..)
  , MonadMask (..)
  , MonadMaskingState (..)
  , MonadEvaluate (..)
  , MaskingState (..)
  , Exception (..)
  , SomeException
  , ExitCase (..)
  , Handler (..)
  , catches
  ) where

import Control.Exception (Exception (..), MaskingState, SomeException)
import Control.Exception qualified as IO
import Control.Monad (liftM)

import Control.Monad.Reader (ReaderT (..), lift, runReaderT)

import Control.Monad.STM (STM)
import Control.Monad.STM qualified as STM

#if __GLASGOW_HASKELL__ >= 910
import GHC.Internal.Exception.Context (ExceptionAnnotation)
#endif

-- | 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

#if __GLASGOW_HASKELL__ >= 910
  {-# MINIMAL throwIO, annotateIO #-}
#else
  {-# MINIMAL throwIO #-}
#endif

  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
#if __GLASGOW_HASKELL__ >= 910
  annotateIO :: forall e a. ExceptionAnnotation e => e -> m a -> m a
#endif

  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 a b c.
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
        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 a b c. 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 a b c. m a -> m b -> m c -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> m b -> m c -> m c
bracket_ (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m b
sequel m a
a

-- | 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 e a. Exception e => 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 e a. Exception e => 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 e a. Exception e => m a -> (e -> m a) -> m 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 a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m a
a) (Either e a -> m (Either e a)
forall a. a -> m 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 e a. Exception e => 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 a. a -> m 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 e a. Exception e => e -> m 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 a. a -> m 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 e a. Exception e => 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 e b a.
Exception e =>
(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 e a. Exception e => m a -> (e -> 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 e a. Exception e => e -> 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 a b c.
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
    m a
acquire
    (\a
a ExitCase c
exitCase -> case ExitCase c
exitCase of
      ExitCaseSuccess c
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ExitCase c
_ -> do
        b
_ <- a -> m b
release a
a
        () -> m ()
forall a. a -> m 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 a. m a -> m a) -> m (b, c)) -> m (b, c)
forall b. ((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, 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 e a. Exception e => m a -> (e -> m a) -> m a
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 e a. Exception e => e -> m a
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 a. a -> m a
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 :: forall (m :: * -> *) a. MonadCatch m => 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 e a. Exception e => m a -> (e -> 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 :: forall (m :: * -> *) a.
MonadCatch m =>
[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 a b. (a -> b -> b) -> b -> [a] -> b
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 e a. Exception e => e -> 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
$cshowsPrec :: forall a. Show a => Int -> ExitCase a -> ShowS
showsPrec :: Int -> ExitCase a -> ShowS
$cshow :: forall a. Show a => ExitCase a -> String
show :: ExitCase a -> String
$cshowList :: forall a. Show a => [ExitCase a] -> ShowS
showList :: [ExitCase a] -> ShowS
Show, (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
$cfmap :: forall a b. (a -> b) -> ExitCase a -> ExitCase b
fmap :: forall a b. (a -> b) -> ExitCase a -> ExitCase b
$c<$ :: forall a b. a -> ExitCase b -> ExitCase a
<$ :: forall a b. a -> ExitCase b -> ExitCase a
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 b. ((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 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 b. ((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 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
  {-# MINIMAL getMaskingState, interruptible #-}
  getMaskingState :: m MaskingState
  interruptible   :: m a -> m a
  allowInterrupt  :: m ()

  allowInterrupt = m () -> m ()
forall a. m a -> m a
forall (m :: * -> *) a. MonadMaskingState m => m a -> m a
interruptible (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())



-- | 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 :: forall e a. Exception e => e -> IO a
throwIO    = e -> IO a
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    = 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_ :: forall a b c. 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 :: forall a b. IO a -> IO b -> IO a
finally    = IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
IO.finally
#if __GLASGOW_HASKELL__ >= 910
  annotateIO = IO.annotateIO
#endif


instance MonadCatch IO where

  catch :: forall e a. Exception e => 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 :: forall e b a.
Exception e =>
(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 :: forall e a. Exception e => 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 :: forall e b a.
Exception e =>
(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 :: forall e a. Exception e => (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 :: forall e b a.
Exception e =>
(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 :: forall a b. 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 :: forall a b c. 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 b. ((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_ :: forall a. IO a -> IO a
mask_ = IO a -> IO a
forall a. IO a -> IO a
IO.mask_

  uninterruptibleMask :: forall b. ((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_ :: forall a. 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
  interruptible :: forall a. IO a -> IO a
interruptible   = IO a -> IO a
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 = a -> IO a
forall a. a -> IO a
IO.evaluate

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

instance MonadThrow STM where
  throwIO :: forall e a. Exception e => e -> STM a
throwIO = e -> STM a
forall e a. Exception e => e -> STM a
STM.throwSTM
#if __GLASGOW_HASKELL__ >= 910
  annotateIO ann io = io `catch` \e -> throwIO (IO.addExceptionContext ann e)
#endif

instance MonadCatch STM where
  catch :: forall e a. Exception e => 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 :: 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 STM b -> (SomeException -> STM b) -> STM b
forall e a. Exception e => STM a -> (e -> STM a) -> STM a
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 e a. Exception e => e -> STM a
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 a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)


--
-- ReaderT instances
--

instance MonadThrow m => MonadThrow (ReaderT r m) where
  throwIO :: forall e a. Exception e => e -> ReaderT r m a
throwIO = m a -> ReaderT r m a
forall (m :: * -> *) a. Monad m => 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 e a. Exception e => e -> m a
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 = (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 a b c. 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)
#if __GLASGOW_HASKELL__ >= 910
  annotateIO ann io = ReaderT $ \env ->
    annotateIO ann (runReaderT io env)
#endif

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 = (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 e a. Exception e => 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 :: 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 = (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 a b c.
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 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 = (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 b. ((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 :: 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) = (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 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 =
    (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 b. ((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 :: 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) = (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 :: forall a. a -> ReaderT r m a
evaluate = m a -> ReaderT r m a
forall (m :: * -> *) a. Monad m => 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 a. a -> m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate