{-# LANGUAGE CPP , NoImplicitPrelude , ExistentialQuantification , FlexibleContexts , ImpredicativeTypes #-} #if MIN_VERSION_base(4,3,0) {-# LANGUAGE RankNTypes #-} -- for mask #endif #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #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 MIN_VERSION_base(4,3,0) || 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 = liftBaseOp E.mask . liftRestore {-# INLINABLE mask #-} liftRestore :: MonadBaseControl IO m => ((forall a. m a -> m a) -> b) -> ((forall a. IO a -> IO a) -> b) liftRestore f r = f $ liftBaseOp_ r {-# INLINE liftRestore #-} -- |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 = liftBaseOp E.uninterruptibleMask . liftRestore {-# 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 #-}