{-# LANGUAGE CPP

           , NoImplicitPrelude

           , ExistentialQuantification

           , FlexibleContexts #-}

#if MIN_VERSION_base(4,3,0)

{-# LANGUAGE RankNTypes #-} -- for mask

#endif

#if __GLASGOW_HASKELL__ >= 702

{-# LANGUAGE Safe #-}

#endif

{- |

Module      :  Control.Exception.Lifted

Copyright   :  Bas van Dijk, Anders Kaseorg

License     :  BSD-style

Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com>

Stability   :  experimental

Portability :  non-portable (extended exceptions)

This is a wrapped version of "Control.Exception" with types generalized

from 'IO' to all monads in either 'MonadBase' or 'MonadBaseControl'.

-}

module Control.Exception.Lifted

    ( module Control.Exception

      -- * Throwing exceptions

    , throwIO, ioError, throwTo

      -- * Catching exceptions

      -- ** The @catch@ functions

    , catch, catches, Handler(..), catchJust

      -- ** The @handle@ functions

    , handle, handleJust

      -- ** The @try@ functions

    , try, tryJust

      -- ** The @evaluate@ function

    , evaluate

      -- * Asynchronous Exceptions

      -- ** Asynchronous exception control

      -- |The following functions allow a thread to control delivery of

      -- asynchronous exceptions during a critical region.

#if MIN_VERSION_base(4,3,0)

    , mask, mask_

    , uninterruptibleMask, uninterruptibleMask_

    , getMaskingState

#if MIN_VERSION_base(4,4,0)

    , allowInterrupt

#endif

#else

    , block, unblock

#endif

#if !MIN_VERSION_base(4,4,0)

    , blocked

#endif

      -- * Brackets

    , bracket, bracket_, bracketOnError

      -- * Utilities

    , finally, onException

    ) where

--------------------------------------------------------------------------------

-- Imports

--------------------------------------------------------------------------------

-- from base:

import Prelude         ( (.) )

import Data.Function   ( ($) )

import Data.Either     ( Either(Left, Right), either )

import Data.Maybe      ( Maybe )

import Control.Monad   ( (>>=), return, liftM )

import System.IO.Error ( IOError )

import System.IO       ( IO )

#if __GLASGOW_HASKELL__ < 700

import Control.Monad   ( fail )

#endif

import Control.Exception hiding

    ( throwIO, ioError, throwTo

    , catch, catches, Handler(..), catchJust

    , handle, handleJust

    , try, tryJust

    , evaluate

#if MIN_VERSION_base(4,3,0)

    , mask, mask_

    , uninterruptibleMask, uninterruptibleMask_

    , getMaskingState

#if MIN_VERSION_base(4,4,0)

    , allowInterrupt

#endif

#else

    , block, unblock

#endif

#if !MIN_VERSION_base(4,4,0)

    , blocked

#endif

    , bracket, bracket_, bracketOnError

    , finally, onException

    )

import qualified Control.Exception  as E

import qualified Control.Concurrent as C

import           Control.Concurrent ( ThreadId )

#if !MIN_VERSION_base(4,4,0)

import Data.Bool ( Bool )

#endif

-- from transformers-base:

import Control.Monad.Base ( MonadBase, liftBase )

-- from monad-control:

import Control.Monad.Trans.Control ( MonadBaseControl, StM

                                   , liftBaseWith, restoreM

                                   , control, liftBaseOp_

                                   )

#if defined (__HADDOCK__)

import Control.Monad.Trans.Control ( liftBaseOp )

#endif

#include "inlinable.h"

--------------------------------------------------------------------------------

-- * Throwing exceptions

--------------------------------------------------------------------------------

-- |Generalized version of 'E.throwIO'.

throwIO :: (MonadBase IO m, Exception e) => e -> m a

throwIO = liftBase . E.throwIO

{-# INLINABLE throwIO #-}

-- |Generalized version of 'E.ioError'.

ioError :: MonadBase IO m => IOError -> m a

ioError = liftBase . E.ioError

{-# INLINABLE ioError #-}

-- | Generalized version of 'C.throwTo'.

throwTo :: (MonadBase IO m, Exception e) => ThreadId -> e -> m ()

throwTo tid e = liftBase $ C.throwTo tid e

{-# INLINABLE throwTo #-}

--------------------------------------------------------------------------------

-- * Catching exceptions

--------------------------------------------------------------------------------

-- |Generalized version of 'E.catch'.

--

-- Note, when the given computation throws an exception any monadic

-- side effects in @m@ will be discarded.

catch :: (MonadBaseControl IO m, Exception e)

      => m a       -- ^ The computation to run

      -> (e -> m a) -- ^ Handler to invoke if an exception is raised

      -> m a

catch a handler = control $ \runInIO ->

                    E.catch (runInIO a)

                            (\e -> runInIO $ handler e)

{-# INLINABLE catch #-}

-- |Generalized version of 'E.catches'.

--

-- Note, when the given computation throws an exception any monadic

-- side effects in @m@ will be discarded.

catches :: MonadBaseControl IO m => m a -> [Handler m a] -> m a

catches a handlers = control $ \runInIO ->

                       E.catches (runInIO a)

                                 [ E.Handler $ \e -> runInIO $ handler e

                                 | Handler handler <- handlers

                                 ]

{-# INLINABLE catches #-}

-- |Generalized version of 'E.Handler'.

data Handler m a = forall e. Exception e => Handler (e -> m a)

-- |Generalized version of 'E.catchJust'.

--

-- Note, when the given computation throws an exception any monadic

-- side effects in @m@ will be discarded.

catchJust :: (MonadBaseControl IO m, Exception e)

          => (e -> Maybe b) -- ^ Predicate to select exceptions

          -> m a           -- ^ Computation to run

          -> (b -> m a)     -- ^ Handler

          -> m a

catchJust p a handler = control $ \runInIO ->

                          E.catchJust p

                                      (runInIO a)

                                      (\e -> runInIO (handler e))

{-# INLINABLE catchJust #-}

--------------------------------------------------------------------------------

--  ** The @handle@ functions

--------------------------------------------------------------------------------

-- |Generalized version of 'E.handle'.

--

-- Note, when the given computation throws an exception any monadic

-- side effects in @m@ will be discarded.

handle :: (MonadBaseControl IO m, Exception e) => (e -> m a) -> m a -> m a

handle handler a = control $ \runInIO ->

                     E.handle (\e -> runInIO (handler e))

                              (runInIO a)

{-# INLINABLE handle #-}

-- |Generalized version of 'E.handleJust'.

--

-- Note, when the given computation throws an exception any monadic

-- side effects in @m@ will be discarded.

handleJust :: (MonadBaseControl IO m, Exception e)

           => (e -> Maybe b) -> (b -> m a) -> m a -> m a

handleJust p handler a = control $ \runInIO ->

                           E.handleJust p (\e -> runInIO (handler e))

                                          (runInIO a)

{-# INLINABLE handleJust #-}

--------------------------------------------------------------------------------

-- ** The @try@ functions

--------------------------------------------------------------------------------

sequenceEither :: MonadBaseControl IO m => Either e (StM m a) -> m (Either e a)

sequenceEither = either (return . Left) (liftM Right . restoreM)

{-# INLINE sequenceEither #-}

-- |Generalized version of 'E.try'.

--

-- Note, when the given computation throws an exception any monadic

-- side effects in @m@ will be discarded.

try :: (MonadBaseControl IO m, Exception e) => m a -> m (Either e a)

try m = liftBaseWith (\runInIO -> E.try (runInIO m)) >>= sequenceEither

{-# INLINABLE try #-}

-- |Generalized version of 'E.tryJust'.

--

-- Note, when the given computation throws an exception any monadic

-- side effects in @m@ will be discarded.

tryJust :: (MonadBaseControl IO m, Exception e) => (e -> Maybe b) -> m a -> m (Either b a)

tryJust p m = liftBaseWith (\runInIO -> E.tryJust p (runInIO m)) >>= sequenceEither

{-# INLINABLE tryJust #-}

--------------------------------------------------------------------------------

-- ** The @evaluate@ function

--------------------------------------------------------------------------------

-- |Generalized version of 'E.evaluate'.

evaluate :: MonadBase IO m => a -> m a

evaluate = liftBase . E.evaluate

{-# INLINABLE evaluate #-}

--------------------------------------------------------------------------------

-- ** Asynchronous exception control

--------------------------------------------------------------------------------

#if MIN_VERSION_base(4,3,0)

-- |Generalized version of 'E.mask'.

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

mask f = control $ \runInBase ->

           E.mask $ \g -> runInBase $ f $ liftBaseOp_ g

{-# INLINABLE mask #-}

-- |Generalized version of 'E.mask_'.

mask_ :: MonadBaseControl IO m => m a -> m a

mask_ = liftBaseOp_ E.mask_

{-# INLINABLE mask_ #-}

-- |Generalized version of 'E.uninterruptibleMask'.

uninterruptibleMask

    :: MonadBaseControl IO m => ((forall a. m a -> m a) -> m b) -> m b

uninterruptibleMask f =

    control $ \runInBase ->

        E.uninterruptibleMask $ \g -> runInBase $ f $ liftBaseOp_ g

{-# INLINABLE uninterruptibleMask #-}

-- |Generalized version of 'E.uninterruptibleMask_'.

uninterruptibleMask_ :: MonadBaseControl IO m => m a -> m a

uninterruptibleMask_ = liftBaseOp_ E.uninterruptibleMask_

{-# INLINABLE uninterruptibleMask_ #-}

-- |Generalized version of 'E.getMaskingState'.

getMaskingState :: MonadBase IO m => m MaskingState

getMaskingState = liftBase E.getMaskingState

{-# INLINABLE getMaskingState #-}

#if MIN_VERSION_base(4,4,0)

-- |Generalized version of 'E.allowInterrupt'.

allowInterrupt :: MonadBase IO m => m ()

allowInterrupt = liftBase E.allowInterrupt

{-# INLINABLE allowInterrupt #-}

#endif

#else

-- |Generalized version of 'E.block'.

block :: MonadBaseControl IO m => m a -> m a

block = liftBaseOp_ E.block

{-# INLINABLE block #-}

-- |Generalized version of 'E.unblock'.

unblock :: MonadBaseControl IO m => m a -> m a

unblock = liftBaseOp_ E.unblock

{-# INLINABLE unblock #-}

#endif

#if !MIN_VERSION_base(4,4,0)

-- | Generalized version of 'E.blocked'.

-- returns @True@ if asynchronous exceptions are blocked in the

-- current thread.

blocked :: MonadBase IO m => m Bool

blocked = liftBase E.blocked

{-# INLINABLE blocked #-}

#endif

--------------------------------------------------------------------------------

-- * Brackets

--------------------------------------------------------------------------------

-- |Generalized version of 'E.bracket'.

--

-- Note:

--

-- * When the \"acquire\" or \"release\" computations throw exceptions

--   any monadic side effects in @m@ will be discarded.

--

-- * When the \"in-between\" computation throws an exception any

--   monadic side effects in @m@ produced by that computation will be

--   discarded but the side effects of the \"acquire\" or \"release\"

--   computations will be retained.

--

-- * Also, any monadic side effects in @m@ of the \"release\"

--   computation will be discarded; it is run only for its side

--   effects in @IO@.

--

-- Note that when your @acquire@ and @release@ computations are of type 'IO'

-- it will be more efficient to write:

--

-- @'liftBaseOp' ('E.bracket' acquire release)@

bracket :: MonadBaseControl IO m

        => m a       -- ^ computation to run first (\"acquire resource\")

        -> (a -> m b) -- ^ computation to run last (\"release resource\")

        -> (a -> m c) -- ^ computation to run in-between

        -> m c

bracket before after thing = control $ \runInIO ->

                               E.bracket (runInIO before)

                                         (\st -> runInIO $ restoreM st >>= after)

                                         (\st -> runInIO $ restoreM st >>= thing)

{-# INLINABLE bracket #-}

-- |Generalized version of 'E.bracket_'.

--

-- Note any monadic side effects in @m@ of /both/ the \"acquire\" and

-- \"release\" computations will be discarded. To keep the monadic

-- side effects of the \"acquire\" computation, use 'bracket' with

-- constant functions instead.

--

-- Note that when your @acquire@ and @release@ computations are of type 'IO'

-- it will be more efficient to write:

--

-- @'liftBaseOp_' ('E.bracket_' acquire release)@

bracket_ :: MonadBaseControl IO m

         => m a -- ^ computation to run first (\"acquire resource\")

         -> m b -- ^ computation to run last (\"release resource\")

         -> m c -- ^ computation to run in-between

         -> m c

bracket_ before after thing = control $ \runInIO ->

                                E.bracket_ (runInIO before)

                                           (runInIO after)

                                           (runInIO thing)

{-# INLINABLE bracket_ #-}

-- |Generalized version of 'E.bracketOnError'.

--

-- Note:

--

-- * When the \"acquire\" or \"release\" computations throw exceptions

--   any monadic side effects in @m@ will be discarded.

--

-- * When the \"in-between\" computation throws an exception any

--   monadic side effects in @m@ produced by that computation will be

--   discarded but the side effects of the \"acquire\" computation

--   will be retained.

--

-- * Also, any monadic side effects in @m@ of the \"release\"

--   computation will be discarded; it is run only for its side

--   effects in @IO@.

--

-- Note that when your @acquire@ and @release@ computations are of

-- type 'IO' it will be more efficient to write:

--

-- @'liftBaseOp' ('E.bracketOnError' acquire release)@

bracketOnError :: MonadBaseControl IO m

               => m a       -- ^ computation to run first (\"acquire resource\")

               -> (a -> m b) -- ^ computation to run last (\"release resource\")

               -> (a -> m c) -- ^ computation to run in-between

               -> m c

bracketOnError before after thing =

    control $ \runInIO ->

      E.bracketOnError (runInIO before)

                       (\st -> runInIO $ restoreM st >>= after)

                       (\st -> runInIO $ restoreM st >>= thing)

{-# INLINABLE bracketOnError #-}

--------------------------------------------------------------------------------

-- * Utilities

--------------------------------------------------------------------------------

-- |Generalized version of 'E.finally'.

--

-- Note, any monadic side effects in @m@ of the \"afterward\"

-- computation will be discarded.

finally :: MonadBaseControl IO m

        => m a -- ^ computation to run first

        -> m b -- ^ computation to run afterward (even if an exception was raised)

        -> m a

finally a sequel = control $ \runInIO ->

                     E.finally (runInIO a)

                               (runInIO sequel)

{-# INLINABLE finally #-}

-- |Generalized version of 'E.onException'.

--

-- Note, any monadic side effects in @m@ of the \"afterward\"

-- computation will be discarded.

onException :: MonadBaseControl IO m => m a -> m b -> m a

onException m what = control $ \runInIO ->

                       E.onException (runInIO m)

                                     (runInIO what)

{-# INLINABLE onException #-}