{-# LANGUAGE CPP #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Exception
(
MonadThrow
, exception
, throw
, throwIO
, ioError
, throwTo
, MonadCatch
, catch
, handle
, catchJust
, handleJust
, Handler(..)
, catches
, handles
, try
, tryJust
, evaluateIO
, MonadMask(..)
, liftGetMaskingState
, liftWithMaskingState
, mask
, mask_
, uninterruptibleMask
, uninterruptibleMask_
, interruptible
, allowInterrupt
, module Control.Monad.Abort.Class
, module Control.Monad.Finally
, module Control.Exception
) where
#if !MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#else
import Prelude hiding (ioError)
#endif
import Data.Monoid (Monoid)
import Control.Applicative (Applicative, (<$>))
import Control.Monad (join, liftM)
import Control.Monad.Base
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control (MonadTransControl(..))
import Control.Monad.Trans.Abort hiding (abort, recover)
import Control.Monad.Trans.Finish
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.List
import Control.Monad.Trans.Error
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import qualified Control.Monad.Trans.State.Lazy as L
import qualified Control.Monad.Trans.State.Strict as S
import qualified Control.Monad.Trans.Writer.Lazy as L
import qualified Control.Monad.Trans.Writer.Strict as S
import qualified Control.Monad.Trans.RWS.Lazy as L
import qualified Control.Monad.Trans.RWS.Strict as S
import Control.Monad.Abort.Class
import Control.Monad.Finally
import Control.Concurrent (ThreadId)
import Control.Exception hiding (
evaluate, throw, throwIO, ioError, throwTo, catch, catchJust, handle,
handleJust, Handler(..), catches, try, tryJust, finally, onException,
#if !MIN_VERSION_base(4,7,0)
block, unblock, blocked,
#endif
getMaskingState, mask, mask_, uninterruptibleMask, uninterruptibleMask_,
#if MIN_VERSION_base(4,9,0)
interruptible,
#endif
allowInterrupt, bracket, bracket_, bracketOnError)
import qualified Control.Exception as E
import GHC.Base (maskAsyncExceptions#, maskUninterruptible#,
unmaskAsyncExceptions#)
import GHC.IO (IO(..))
type MonadThrow μ = MonadAbort SomeException μ
exception ∷ Exception e ⇒ e → α
exception = E.throw
{-# INLINE exception #-}
throw ∷ (MonadThrow μ, Exception e) ⇒ e → μ α
throw = abort . toException
{-# INLINE throw #-}
throwIO ∷ (MonadBase IO μ, Exception e) ⇒ e → μ α
throwIO = liftBase . E.throwIO
{-# INLINE throwIO #-}
ioError ∷ MonadBase IO μ ⇒ IOError → μ α
ioError = liftBase . E.ioError
{-# INLINE ioError #-}
throwTo ∷ (MonadBase IO μ, Exception e) ⇒ ThreadId → e → μ ()
throwTo = fmap liftBase . E.throwTo
{-# INLINE throwTo #-}
type MonadCatch μ = MonadRecover SomeException μ
catch ∷ (MonadCatch μ, Exception e) ⇒ μ α → (e → μ α) → μ α
catch m h = recover m $ \e → maybe (throw e) h (fromException e)
{-# INLINE catch #-}
handle ∷ (MonadCatch μ, Exception e) ⇒ (e → μ α) → μ α → μ α
handle = flip catch
{-# INLINE handle #-}
catchJust ∷ (MonadCatch μ, Exception e)
⇒ (e → Maybe β)
→ μ α
→ (β → μ α)
→ μ α
catchJust f m h = catch m $ \e → maybe (throw e) h $ f e
{-# INLINE catchJust #-}
handleJust ∷ (MonadCatch μ, Exception e)
⇒ (e → Maybe β) → (β → μ α) → μ α → μ α
handleJust = flip . catchJust
{-# INLINE handleJust #-}
data Handler μ α = ∀ e . Exception e ⇒ Handler (e → μ α)
instance Functor μ ⇒ Functor (Handler μ) where
fmap f (Handler h) = Handler (fmap f . h)
{-# INLINE fmap #-}
catches ∷ MonadCatch μ ⇒ μ α → [Handler μ α] → μ α
catches m = recover m . hl
where hl [] e = abort e
hl (Handler h : hs) e = maybe (hl hs e) h $ fromException e
handles ∷ MonadCatch μ ⇒ [Handler μ α] → μ α → μ α
handles = flip catches
{-# INLINE handles #-}
try ∷ (MonadCatch μ, Exception e) ⇒ μ α → μ (Either e α)
try m = catch (Right <$> m) (return . Left)
{-# INLINE try #-}
tryJust ∷ (MonadCatch μ, Exception e)
⇒ (e → Maybe β)
→ μ α
→ μ (Either β α)
tryJust h m = catch (Right <$> m) $ \e →
maybe (throw e) (return . Left) (h e)
{-# INLINE tryJust #-}
evaluateIO ∷ MonadBase IO μ ⇒ α → μ α
evaluateIO = liftBase . E.evaluate
{-# INLINE evaluateIO #-}
class (Applicative μ, Monad μ) ⇒ MonadMask μ where
getMaskingState ∷ μ MaskingState
default getMaskingState ∷ (MonadMask η, MonadTrans t, μ ~ t η)
⇒ μ MaskingState
getMaskingState = liftGetMaskingState
{-# INLINE getMaskingState #-}
withMaskingState ∷ MaskingState → μ α → μ α
default withMaskingState ∷ (MonadMask η, MonadTransControl t, μ ~ t η)
⇒ MaskingState → μ α → μ α
withMaskingState = liftWithMaskingState
{-# INLINE withMaskingState #-}
liftGetMaskingState ∷ (MonadMask μ, MonadTrans t) ⇒ t μ MaskingState
liftGetMaskingState = lift getMaskingState
{-# INLINE liftGetMaskingState #-}
liftWithMaskingState ∷ (MonadTransControl t, MonadMask μ, Monad (t μ))
⇒ MaskingState → t μ α → t μ α
liftWithMaskingState ms m =
join $ liftM (restoreT . return) $ liftWith $ \run →
withMaskingState ms (run m)
{-# INLINE liftWithMaskingState #-}
instance MonadMask IO where
getMaskingState = E.getMaskingState
withMaskingState Unmasked (IO io) = IO $ unmaskAsyncExceptions# io
withMaskingState MaskedInterruptible (IO io) = IO $ maskAsyncExceptions# io
withMaskingState MaskedUninterruptible (IO io) = IO $ maskUninterruptible# io
instance MonadMask μ ⇒ MonadMask (MaybeT μ)
instance MonadMask μ ⇒ MonadMask (ListT μ)
instance MonadMask μ ⇒ MonadMask (AbortT e μ)
instance MonadMask μ ⇒ MonadMask (FinishT β μ)
instance (MonadMask μ, Error e) ⇒ MonadMask (ErrorT e μ)
instance MonadMask μ ⇒ MonadMask (ExceptT e μ)
instance MonadMask μ ⇒ MonadMask (ReaderT r μ)
instance MonadMask μ ⇒ MonadMask (L.StateT s μ)
instance MonadMask μ ⇒ MonadMask (S.StateT s μ)
instance (MonadMask μ, Monoid w) ⇒ MonadMask (L.WriterT w μ)
instance (MonadMask μ, Monoid w) ⇒ MonadMask (S.WriterT w μ)
instance (MonadMask μ, Monoid w) ⇒ MonadMask (L.RWST r w s μ)
instance (MonadMask μ, Monoid w) ⇒ MonadMask (S.RWST r w s μ)
mask ∷ ∀ μ α . MonadMask μ
⇒ ((∀ η β . MonadMask η ⇒ η β → η β) → μ α) → μ α
mask f = getMaskingState >>= \case
Unmasked →
withMaskingState MaskedInterruptible $ f (withMaskingState Unmasked)
MaskedInterruptible →
f (withMaskingState MaskedInterruptible)
MaskedUninterruptible →
f (withMaskingState MaskedUninterruptible)
mask_ ∷ ∀ μ α . MonadMask μ ⇒ μ α → μ α
mask_ = mask . const
{-# INLINE mask_ #-}
uninterruptibleMask ∷ MonadMask μ
⇒ ((∀ η β . MonadMask η ⇒ η β → η β) → μ α) → μ α
uninterruptibleMask f = getMaskingState >>= \case
Unmasked →
withMaskingState MaskedUninterruptible $ f (withMaskingState Unmasked)
MaskedInterruptible →
withMaskingState MaskedUninterruptible $
f (withMaskingState MaskedInterruptible)
MaskedUninterruptible →
f (withMaskingState MaskedUninterruptible)
uninterruptibleMask_ ∷ MonadMask μ ⇒ μ α → μ α
uninterruptibleMask_ = uninterruptibleMask . const
{-# INLINE uninterruptibleMask_ #-}
interruptible ∷ MonadMask μ ⇒ μ α → μ α
interruptible m = getMaskingState >>= \case
Unmasked → m
MaskedInterruptible → withMaskingState Unmasked m
MaskedUninterruptible → m
allowInterrupt ∷ MonadMask μ ⇒ μ ()
allowInterrupt = interruptible $ return ()
{-# INLINE allowInterrupt #-}