diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,16 @@ +# ChangeLog / ReleaseNotes + +## Version 2.0.0.0 + +* Rewritten to use classes from [exceptions][] package. +* Uploaded to [Hackage][]: + + + + +[exceptions]: + http://hackage.haskell.org/package/exceptions + "Extensible optionally-pure exceptions." +[Hackage]: + http://hackage.haskell.org/ + "HackageDB (or just Hackage) is a collection of releases of Haskell packages." diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009 - 2014, Peter Trsko + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Peter Trsko nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Control/Monad/TaggedException.hs b/src/Control/Monad/TaggedException.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/TaggedException.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +-- | +-- Module: $HEADER$ +-- Copyright: (c) 2009 - 2014 Peter Trsko +-- License: BSD3 +-- +-- Stability: provisional +-- Portability: non-portable (CPP, NoImplicitPrelude, depends on non-portable +-- modules) +module Control.Monad.TaggedException + ( + -- * Introduction + -- + -- | This library provides interface that is similar to base's /Extensible + -- Exceptions/. It introduces 'Throws' monad transformer that uses phantom + -- type to tag code that may raise exception. Intention is to make + -- exceptions explicit and to enforce exception handling. + -- + -- This approach is based on commonly used techniques: + -- + -- * /Phantom Types/ + -- + -- * /Type Witnesses/ + + -- ** Why use this? + -- + -- | Exceptions are one of the fastest and most scalable ways of handling + -- failures and errors. One of the downsides of exceptions as defined in + -- Haskell is that they aren't visible in type signatures as in example + -- when using 'Data.Maybe.Maybe' or 'Control.Monad.Trans.Except.ExceptT'. + -- + -- This library tries to get rid of this issue by making exceptions + -- visible. On the other hand it makes things little more complicated, but + -- fortunatelly not too much. + -- + -- Some of the benefits of this approach are listed bellow. + + -- *** Unification of exception handling + + -- | Raising and handling exception becomes the same for all + -- 'Control.Monad.Catch.MonadThrow' and 'Control.Monad.Catch.MonadCatch' + -- instances. This includes code that uses exceptions in @IO@ monad and + -- @ErrorT@ style error handling. All that can be easily modified to use + -- API defined by this library. + -- + -- For ilustration there is a great summary of various ways of error + -- handling in Haskell: + -- + -- * + -- + -- * + -- + -- Posts mentioned above show that any unification or framework for + -- transforming one error handling technique to another are very benefitial + -- in practice. + + -- *** Avoiding fail + -- + -- | Sometimes @'Monad'('fail')@ is used to generalize exception handling. + -- While it provides a generalized interface it also introduces controversy + -- that sorrounds 'fail'. + -- + -- This library allows usege of similar approach without using 'fail' and + -- with explicitly visible exception. + -- + -- Instead of function like: + -- + -- > lookup + -- > :: Monad m + -- > => Container Key Value + -- > -> Key + -- > -> m Value + -- + -- this library allows to write: + -- + -- > lookup + -- > :: MonadThrow m + -- > => Container Key Value + -- > -> Key + -- > -> Throw LookupFailure m Value + -- + -- where @LookupFailure@ is instance of 'Control.Exception.Exception' + -- class. While in some ways it's similar to using + -- 'Control.Monad.Trans.Except.ExceptT', it has all the flexibility of + -- /extensible-exceptions/ for arbitrary 'Control.Monad.Catch.MonadThrow' + -- instance. + + -- ** Dependencies + -- + -- | This package is trying to keep dependencies at minimum. Here is list + -- of current dependencies: + -- + -- * /base/ + -- + -- * /exceptions/: Provides 'Control.Monad.Catch.MonadThrow', + -- 'Control.Monad.Catch.MonadCatch' and 'Control.Monad.Catch.MonadMask' + -- type classes. + -- + -- * /extensible-exceptions/ for /4 >= base < 4.2/ + -- + -- * /transformers >= 0.2 && < 0.4/: De facto current standard for monad + -- transformers. Included in newer versions of HaskellPlatform. + -- + -- * /mmorph/ >= 1.0.0 && < 1.1: Monad morphism utilities. Currently not + -- in HaskellPlatform. + + -- ** Naming conventions + -- + -- | Names of basic functions are the same as those in "Control.Exception" + -- module, but differ in it's type signature. They operate on tagged code + -- and are therefore limited to operate only on exceptions specified by the + -- phantom type. + -- + -- Exception, to above rule, is 'throw' function which does not throw + -- exception from pure code, as does 'Control.Exception.throw', but from + -- monadic code. So, it is more equivalent to 'Control.Exception.throwIO'. + + -- *** \ vs. \' + -- + -- | Functions with prime at the end of there name aren't restricted by the + -- phantom type while those without it are. Functions with prime can + -- therefore operate on arbitrary exceptions. Use such functions when + -- operating on exceptions that are different from exception specified by a + -- phantom type, i.e. hidden ones. + -- + -- In case of 'System.IO.IO' monad, primed functions behave as those from + -- "Control.Exception" module with the same name, but without prime of + -- course. + + -- *** lift\T vs. liftT\ + -- + -- | The @lift\T@ are basicaly saying lift \ times (e.g. @'lift2T' + -- = 'liftT' . 'liftT'@) while @liftT\@ says lift one time but operate + -- on function with arity \. This was choosen to be consistent with + -- @liftM@, @liftM2@, @liftA@, @liftA2@, etc. + + -- * Usage + -- $usage + + -- ** Importing + -- + -- | When using older /base/ library function 'catch' clashes with + -- @Prelude(catch)@, so either import with hidden @Prelude(catch)@: + -- + -- > import Prelude hiding (catch) + -- > import Control.Monad.TaggedException + -- + -- or use import like: + -- + -- > import Control.Monad.TaggedException as E + -- + -- and then use @E.catch@, in later case you can also use qualified import: + -- + -- > import qualified Control.Monad.TaggedException as E + -- + -- It is recomended to use explicit import list or, as mentioned before, + -- qualified import. See also /Import modules properly/ on /Haskell Wiki/: + -- . + -- + -- Classes 'Control.Monad.Catch.MonadCatch', + -- 'Control.Monad.Catch.MonadThrow' and 'Control.Monad.Catch.MonadMask' + -- aren't reexported. To use them in your type signatures you'll need to + -- import them from /exceptions/ package: + -- + -- > import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) + -- + -- Same goes for 'Exception' class which is provided by /base/ (or by + -- /extensible-exceptions/ for older bases): + -- + -- > import Control.Exception (Exception) + + -- * API documentation + + -- ** Library core + -- + -- | Basic library interface. Main idea behind it is to provide very + -- stable API that can be imported directly from + -- "Control.Monad.TaggedException.Core" module or as part of this one. + -- + -- Among others it provides: + -- + -- * 'Throws' newtype that is used for tagging monadic code with exception + -- type. + -- + -- * A lot of combinators for tagged monadic code. In example \"@'liftT' :: + -- ('Exception' e, 'MonadThrow' m) => m a -> 'Throws' e m a@\" lifts + -- monadic code in to tagged monadic code. + -- + -- * Functions defined on top of 'Control.Monad.Catch.MonadThrow' and + -- 'MonadCatch', like 'throw', 'catch' and 'handle'. + module Control.Monad.TaggedException.Core + + -- ** Hidden exceptions + -- + -- | Support for hidden/uncaught exceptions. The ideas behind hiding + -- thrown exception is: + -- + -- 1. Be compatible with /extensible-exceptions/ ("Control.Exception"), + -- in sense that all current @IO@ code doesn't reflect raised + -- exceptions in it's type. All standard exceptions, exported by + -- "Control.Exception" module, are instances of 'HiddenException'. + -- + -- 2. Programs, and their code, are multilayered things. Sometimes + -- exceptions aren't ment to be caught in certain layers. See also + -- + -- on /Haskell Wiki/. + -- + -- See "Control.Monad.TaggedException.Hidden" for examples. + , module Control.Monad.TaggedException.Hidden + + -- ** Asynchronous exceptions and bracket family of functions + , module Control.Monad.TaggedException.Utilities + + -- * Some related work + -- + -- | There is already more then one package that introduces similar + -- interfaces and also many others that are dealing with the same problem + -- domain. Just to list some: + -- + -- * + -- + -- * : + -- Exception monad transformer with explicitly typed exceptions. + -- + -- * : + -- Synchronous and Asynchronous exceptions which are explicit in the type + -- signature. + -- + -- * with instances + -- for + -- defined in + -- . + -- + -- * + -- and + -- : + -- This libraries export @class MonadIO m => MonadCatchIO m@ that catches + -- lifting neccessary for exception handling in encapsulated + -- 'System.IO.IO' monad. + -- + -- * : + -- Based on /monad-peel/. + -- + -- * + + ) + where + +import Control.Monad.TaggedException.Core +import Control.Monad.TaggedException.Hidden +import Control.Monad.TaggedException.Utilities + +-- $usage +-- +-- Example of reflecting reised exception in type: +-- +-- > {-# LANGUAGE DeriveDataTypeable #-} +-- > +-- > import Control.Exception (Exception) +-- > +-- > import Control.Monad.TaggedException (Throws) +-- > import qualified Control.Monad.TaggedException as E (liftT, throw) +-- > import Data.Typeable (Typeable) +-- > +-- > +-- > data NotReady = NotReady String +-- > deriving (Show, Typeable) +-- > -- Both required by Exception class +-- > +-- > instance Exception NotReady +-- > +-- > myFunction :: Input -> Throws NotReady IO Output +-- > myFunction input = do +-- > +-- > ... some stuff ... +-- > +-- > -- isReady :: Input -> IO Bool +-- > ready <- E.liftT $ isReady input +-- > unless ready +-- > . E.throw $ NotReady "Resource of myFunction is not ready." +-- > +-- > ... some other stuff ... +-- +-- Caller of this function is forced to catch/handle this exception or reflect +-- it in it's type too. +-- +-- See "Control.Monad.TaggedException.Core" and +-- "Control.Monad.TaggedException.Hidden" for more examples. diff --git a/src/Control/Monad/TaggedException/Core.hs b/src/Control/Monad/TaggedException/Core.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/TaggedException/Core.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Core functionality. +-- Copyright: (c) 2009 - 2014 Peter Trsko. +-- License: BSD3 +-- +-- Stability: provisional +-- Portability: non-portable (NoImplicitPrelude, depends on non-portable +-- modules) +-- +-- Core functionality. +module Control.Monad.TaggedException.Core + ( + -- * MonadException + throw + , catch + , catch' + , handle + , handle' + , try + , mapException + , onException + , onException' + + -- * Exception tag + , Throws + + -- ** Cobinators + , liftT + , lift2T + , lift3T + , liftT1 + , liftT2 + , liftT3 + , joinT + , joinT3 + , flipT + , insideT + , insideT2 + , insideT3 + , insideTf + , insideTf2 + , embedT + ) + where + +import Control.Exception (Exception) +import Data.Either (Either) +import Data.Function ((.), flip) +import Data.Functor (Functor) + +import Control.Monad.Catch (MonadCatch, MonadThrow) +import qualified Control.Monad.Catch as Exceptions + +import Control.Monad.TaggedException.Internal.Throws (Throws(Throws)) +import qualified Control.Monad.TaggedException.Unsafe as Unsafe + ( embedT + , flipT + , insideT + , insideT2 + , insideT3 + , insideTf + , insideTf2 + , joinT + , joinT3 + , liftT1 + , liftT2 + , liftT3 + , throwsOne + , throwsThree + , throwsTwo + ) + + +-- | Throw an exception. To raise an \"inner\" exception following can be +-- used: +-- +-- @ +-- 'liftT' . 'throw' +-- :: ('MonadCatch' m, 'Exception' e, 'Exception' e') +-- => e +-- -> 'Throws' e' ('Throws' e m) a +-- @ +throw :: (Exception e, MonadThrow m) => e -> Throws e m a +throw = Throws . Exceptions.throwM + +-- | Catch exception. +-- +-- To catch inner exception following construct can be used: +-- +-- @ +-- 'catch' . 'flipT' +-- :: ('Exception' e, 'Exception' e', 'MonadCatch' m) +-- => 'Throws' e' ('Throws' e m) a +-- -> (e -> 'Throws' e' m a) +-- -> 'Throws' e' m a +-- @ +catch :: (Exception e, MonadCatch m) => Throws e m a -> (e -> m a) -> m a +catch (Throws ma) = Exceptions.catch ma + +-- | Catch any exception. +catch' :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a +catch' = Exceptions.catch + +-- | Flipped version of 'catch'. Usage example: +-- +-- @ +-- foo = 'handle' exceptionHandler $ do +-- ... +-- where exceptionHandler = ... +-- @ +-- +-- Handle \"inner\" exception: +-- +-- @ +-- 'insideT' . 'handle' +-- :: ('MonadCatch' m, 'Exception' e, 'Exception' e') +-- => (e' -> m a) +-- -> 'Throws' e ('Throws' e' m) a +-- -> 'Throws' e m a +-- @ +handle + :: (Exception e, MonadCatch m) + => (e -> m a) + -> Throws e m a + -> m a +handle = flip catch +{-# INLINE handle #-} + +-- | Flipped version of 'catch'' +handle' + :: (Exception e, MonadCatch m) + => (e -> m a) + -> m a + -> m a +handle' = flip catch' +{-# INLINE handle' #-} + +-- | Similar to 'catch', but returns 'Either' exception or result. +-- +-- Inner try: +-- +-- @ +-- 'try' . 'flipT' +-- :: ('Exception' e, 'Exception' e', MonadCatch m) +-- => 'Throws' e' ('Throws' e m) a +-- -> 'Throws' e' m ('Either' e a) +-- @ +try + :: (Exception e, MonadCatch m) + => Throws e m a + -> m (Either e a) +try (Throws ma) = Exceptions.try ma + +-- | Map one exception to another. +-- +-- Mapping \"inner\" exception has generally two forms: +-- +-- 1\. Modifying raised exception, but not changing its type: +-- +-- @ +-- 'liftT1' . 'mapException' +-- :: ('Exception' e, 'Exception' e', 'MonadCatch' m) +-- => (e -> e) +-- -> 'Throws' e' ('Throws' e m) a +-- -> 'Throws' e' ('Throws' e m) a +-- @ +-- +-- 2\. Modifying raised exception, including its type: +-- +-- @ +-- 'insideT' . 'mapException' +-- :: ('Exception' e, 'Exception' e1, 'Exception' e2, 'MonadCatch' m) +-- => (e1 -> e2) +-- -> 'Throws' e ('Throws' e1 m) a +-- -> 'Throws' e ('Throws' e2 m) a +-- @ +-- +-- Unhiding exception by mapping it in to a different type of exception: +-- +-- @ +-- \\f -> 'mapException' f . 'liftT' +-- :: ('Exception' e, 'Exception' e', 'MonadCatch' m) +-- => (e -> e') +-- -> m a +-- -> 'Throws' e' m a +-- @ +mapException + :: (Exception e, Exception e', MonadCatch m) + => (e -> e') + -> Throws e m a + -> Throws e' m a +mapException = flip (catch . flipT . liftT) . (throw .) + +-- | Run computation if exception was raised. Basically: +-- +-- @ +-- m ``onException`` n = 'liftT' m ``catch`` \\e -> 'liftT' n >> 'throw' e +-- @ +onException + :: (Exception e, MonadCatch m) + => Throws e m a + -- ^ Computation that may raise exception + -> m b + -- ^ The computation to run if an exception @e@ is raised + -> Throws e m a +onException (Throws ma) = Throws . Exceptions.onException ma + +-- | Same as 'onException', but uses 'catch'' and so second computation is +-- executed if any exception is raised. +onException' + :: (MonadCatch m) + => m a + -- ^ Computation that may raise exception + -> m b + -- ^ The computation to run if an exception is raised + -> m a +onException' = Exceptions.onException + +-- {{{ Exception tag -- Combinators ------------------------------------------- + +-- | Construct exception tag, with type restrictions. +-- +-- Reflect raised exception in function's type: +-- +-- > import Control.Monad.TaggedException (Throws, liftT) +-- > import System.IO (Handle, IOMode) +-- > import qualified System.IO as IO (openFile) +-- > +-- > +-- > openFile :: FilePath -> IOMode -> Throws IOError IO Handle +-- > openFile = (liftT .) . IO.openFile +-- +-- Lifting @m@ to @'Throws' e m@: +-- +-- > import Control.Exception (Exception) +-- > +-- > import Control.Monad.TaggedException (Throws, liftT, throw) +-- > import Data.Typeable (Typeable) +-- > +-- > +-- > data EmptyString = EmptyString +-- > deriving (Show, Typeable) +-- > +-- > instance Exception EmptyString +-- > +-- > writeIfNotEmpty +-- > :: FilePath +-- > -> String +-- > -> Throws EmptyString IO () +-- > writeIfNotEmpty filename str = do +-- > when (null str) $ throw EmptyString +-- > liftT $ writeFile filename str +-- +-- We have a some commonly used patterns: +-- +-- @ +-- ('liftT' .) +-- :: ('Exception' e, 'MonadThrow' m) +-- => (a -> m b) +-- -> a -> 'Throws' e m b +-- @ +-- +-- Above is also usable for lifting throw-like functions: +-- +-- @ +-- import Control.Monad.Trans.Class (MonadTrans(lift)) +-- +-- (('liftT' . 'Control.Monad.Trans.Class.lift') .) +-- :: ( 'Exception' e +-- , 'MonadThrow' m +-- , 'MonadThrow' (t m) +-- , 'Control.Monad.Trans.Class.MonadTrans' t) +-- => (a -> m b) +-- -> a -> 'Throws' e (t m) b +-- @ +liftT :: (Exception e, MonadThrow m) => m a -> Throws e m a +liftT = Unsafe.throwsOne +{-# INLINE liftT #-} + +-- | Shorthand for @'liftT' . 'liftT'@. +lift2T + :: (Exception e, Exception e', MonadThrow m) + => m a + -> Throws e' (Throws e m) a +lift2T = Unsafe.throwsTwo +{-# INLINE lift2T #-} + +-- | Shorthand for @'liftT' . 'liftT' . 'liftT'@. +lift3T + :: (Exception e, Exception e', Exception e'', MonadThrow m) + => m a + -> Throws e'' (Throws e' (Throws e m)) a +lift3T = Unsafe.throwsThree +{-# INLINE lift3T #-} + +-- | 'liftT' for functions with arity one. +liftT1 + :: (Exception e, MonadThrow m) + => (m a -> m b) + -> Throws e m a -> Throws e m b +liftT1 = Unsafe.liftT1 +{-# INLINE liftT1 #-} + +-- | 'liftT' for functions with arity two. +liftT2 + :: (Exception e, MonadThrow m) + => (m a -> m b -> m c) + -> Throws e m a -> Throws e m b -> Throws e m c +liftT2 = Unsafe.liftT2 +{-# INLINE liftT2 #-} + +-- | 'liftT' for functions with arity three. +liftT3 + :: (Exception e, MonadThrow m) + => (m a -> m b -> m c -> m d) + -> Throws e m a -> Throws e m b -> Throws e m c -> Throws e m d +liftT3 = Unsafe.liftT3 +{-# INLINE liftT3 #-} + +-- | Join two outermost exception tags. +joinT + :: (Exception e, MonadThrow m) + => Throws e (Throws e m) a + -> Throws e m a +joinT = Unsafe.joinT +{-# INLINE joinT #-} + +-- | Join three outermost exception tags. +joinT3 + :: (Exception e, MonadThrow m) + => Throws e (Throws e (Throws e m)) a + -> Throws e m a +joinT3 = Unsafe.joinT3 +{-# INLINE joinT3 #-} + +-- | Flip two outermost exception tags. +flipT + :: (Exception e, Exception e', MonadThrow m) + => Throws e' (Throws e m) a + -> Throws e (Throws e' m) a +flipT = Unsafe.flipT +{-# INLINE flipT #-} + +-- | Generalized 'liftT'. Usage examples: +-- +-- @ +-- 'insideT' lift +-- :: ('MonadThrow' (t m), 'MonadThrow' m, 'Exception' e, MonadTrans t) +-- => 'Throws' e m b +-- -> 'Throws' e (t m) b +-- @ +-- +-- This is variation on the first example that explicitly lifts monad: +-- +-- 'insideT' WriterT +-- :: ('Exception' e, 'MonadThrow' m, Monoid w) +-- => 'Throws' e m (b, w) +-- -> 'Throws' e (WriterT w m) b +-- +-- Some useful compositions of exception tag combinators: +-- +-- @ +-- 'insideT' 'flipT' +-- :: ('Exception' e0, 'Exception' e1, 'Exception' e2, 'MonadThrow' m) +-- => 'Throws' e0 ('Throws' e1 ('Throws' e2 m)) a +-- -> 'Throws' e0 ('Throws' e2 ('Throws' e1 m)) a +-- @ +-- +-- @ +-- 'flipT' . 'insideT' 'flipT' +-- :: ('Exception' e0, 'Exception' e1, 'Exception' e2, 'MonadThrow' m) +-- => 'Throws' e0 ('Throws' e1 ('Throws' e2 m)) a +-- -> 'Throws' e2 ('Throws' e0 ('Throws' e1 m)) a +-- @ +insideT + :: (Exception e, MonadThrow m, MonadThrow m') + => (m a -> m' b) + -> Throws e m a -> Throws e m' b +insideT = Unsafe.insideT +{-# INLINE insideT #-} + +-- | Variant of 'insideT'. +-- +-- Usage example: +-- +-- @ +-- 'insideTf' StateT +-- :: ('Exception' e, 'MonadThrow' m) +-- => (s -> 'Throws' e m (a, s)) +-- -> 'Throws' e (StateT s m) a +-- @ +insideTf + :: (Exception e, Functor f, MonadThrow m, MonadThrow m') + => (f (m a) -> m' b) + -> f (Throws e m a) + -> Throws e m' b +insideTf = Unsafe.insideTf +{-# INLINE insideTf #-} + +-- | Variant of 'insideT'. +-- +-- Usage example: +-- +-- @ +-- 'insideTf2' RWST +-- :: ('Exception' e, 'MonadThrow' m) +-- => (r -> s -> 'Throws' e m (a, s, w)) +-- -> 'Throws' e (RWST r w s m) a +-- @ +insideTf2 + :: (Exception e, Functor f, Functor f', MonadThrow m, MonadThrow m') + => (f (f' (m a)) -> m' b) + -> f (f' (Throws e m a)) + -> Throws e m' b +insideTf2 = Unsafe.insideTf2 +{-# INLINE insideTf2 #-} + +-- | Generalized 'liftT2'. +insideT2 + :: (Exception e, MonadThrow m1, MonadThrow m2, MonadThrow m3) + => (m1 a -> m2 b -> m3 c) + -> Throws e m1 a -> Throws e m2 b -> Throws e m3 c +insideT2 = Unsafe.insideT2 +{-# INLINE insideT2 #-} + +-- | Generalized 'liftT3'. +insideT3 + :: (Exception e, MonadThrow m1, MonadThrow m2, MonadThrow m3, + MonadThrow m4) + => (m1 a -> m2 b -> m3 c -> m4 d) + -> Throws e m1 a -> Throws e m2 b -> Throws e m3 c -> Throws e m4 d +insideT3 = Unsafe.insideT3 +{-# INLINE insideT3 #-} + +-- | +-- +-- Since @1.2.0.0@ +embedT :: (Exception e, MonadThrow m, MonadThrow m') + => (m a -> Throws e m' b) + -> Throws e m a -> Throws e m' b +embedT = Unsafe.embedT +{-# INLINE embedT #-} + +-- }}} Exception tag -- Combinators ------------------------------------------- diff --git a/src/Control/Monad/TaggedException/Hidden.hs b/src/Control/Monad/TaggedException/Hidden.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/TaggedException/Hidden.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Support for hidden exceptions. +-- Copyright: (c) 2009 - 2014 Peter Trsko +-- License: BSD3 +-- +-- Stability: provisional +-- Portability: non-portable (CPP, NoImplicitPrelude, depends on non-portable +-- module) +module Control.Monad.TaggedException.Hidden + ( + -- * HiddenException class + -- + -- | Since 'HiddenException' provides default implementation for 'hide' + -- method making instances of it is trivial. Example of how to create + -- instance of HiddenException: + -- + -- > data MyException = MyException String + -- > deriving (Typeable) + -- > + -- > instance Show MyException where + -- > showsPrec _ (MyException msg) = + -- > showString "MyException: " . shows msg + -- > + -- > instance Exception MyException + -- > instance HiddenException MyException + HiddenException(..) + + -- ** Mapping existing visible exception to hidden ones + -- + -- | This is a prefered way of hiding exceptions. Difference from just + -- hiding the type tag and mapping it in to hidden exception is that in + -- later case we can provide additional information. Most important is to + -- specify why that particluar exception was hidden. + -- + -- Example: + -- + -- > data UnrecoverableException + -- > = UnrecoverableIOException String IOException + -- > deriving (Typeable) + -- > + -- > instance Show UnrecoverableException where + -- > showsPrec _ (UnrecoverableIOException info e) + -- > showString "Unrecoverable exception occurred in " + -- > . showString info . showString ": " . shows e + -- > + -- > instance Exception UnrecoverableException + -- > instance HiddenException UnrecoverableException + -- > + -- > hideIOException + -- > :: (MonadCatch e) + -- > => String + -- > -> Throws IOException m a + -- > -> m a + -- > hideIOException = hideWith . UnrecoverableIOException + , hideWith + + -- ** Raising hidden exceptions + , throwHidden + , throw' + ) + where + +import Control.Exception (Exception) +import qualified Control.Exception as E + ( ArithException + , ArrayException + , AssertionFailed + , AsyncException +#if MIN_VERSION_base(4,2,0) + , BlockedIndefinitelyOnMVar + , BlockedIndefinitelyOnSTM +#else + , BlockedIndefinitely + , BlockedOnDeadMVar +#endif + , Deadlock + , ErrorCall + , IOException + , NestedAtomically + , NoMethodError + , NonTermination + , PatternMatchFail + , RecConError + , RecSelError + , RecUpdError +#if MIN_VERSION_base(4,7,0) + , SomeAsyncException +#endif + , SomeException + ) +import Data.Dynamic (Dynamic) +import Data.Function ((.)) +import System.Exit (ExitCode) + +import Control.Monad.Catch (MonadCatch, MonadThrow) +import qualified Control.Monad.Catch as Exceptions + ( MonadCatch(catch) + , MonadThrow(throwM) + ) + +-- This module depends only on internals and nothing else from this package. +-- Try, hard, to keep it that way. +import Control.Monad.TaggedException.Internal.Throws (Throws(Throws)) +import qualified Control.Monad.TaggedException.Internal.Throws as Internal + (Throws(hideException)) + + +-- | Class for exception that can be removed from the type signature. Default +-- implementation for 'hideException' method is provided. +class Exception e => HiddenException e where + -- | Hide exception tag. + hideException :: MonadThrow m => Throws e m a -> m a + hideException = Internal.hideException + {-# INLINE hideException #-} + +-- {{{ HiddenException -- Instances ------------------------------------------- +-- (sorted alphabetically) + +instance HiddenException Dynamic +instance HiddenException E.ArithException +instance HiddenException E.ArrayException +instance HiddenException E.AssertionFailed +instance HiddenException E.AsyncException +#if MIN_VERSION_base(4,2,0) +instance HiddenException E.BlockedIndefinitelyOnMVar +instance HiddenException E.BlockedIndefinitelyOnSTM +#else +instance HiddenException E.BlockedIndefinitely +instance HiddenException E.BlockedOnDeadMVar +#endif +instance HiddenException E.Deadlock +instance HiddenException E.ErrorCall +instance HiddenException E.IOException +instance HiddenException E.NestedAtomically +instance HiddenException E.NoMethodError +instance HiddenException E.NonTermination +instance HiddenException E.PatternMatchFail +instance HiddenException E.RecConError +instance HiddenException E.RecSelError +instance HiddenException E.RecUpdError +#if MIN_VERSION_base(4,7,0) +instance HiddenException E.SomeAsyncException +#endif +instance HiddenException E.SomeException +instance HiddenException ExitCode + +-- }}} HiddenException -- Instances ------------------------------------------- + +-- | Map exception before hiding it. +-- +-- This is the preferred way to do exception hiding, by mapping it in to a +-- different exception that better describes its fatality. +hideWith + :: (Exception e, HiddenException e', MonadCatch m) + => (e -> e') + -> Throws e m a + -> m a +hideWith f (Throws ma) = Exceptions.catch ma (Exceptions.throwM . f) + +-- | Throw exceptions and then disregard type tag. +throwHidden + :: (HiddenException e, MonadThrow m) + => e + -> m a +throwHidden = Exceptions.throwM +{-# INLINE throwHidden #-} + +-- | Alias for @throwHidden@. +throw' + :: (HiddenException e, MonadThrow m) + => e + -> m a +throw' = Exceptions.throwM +{-# INLINE throw' #-} diff --git a/src/Control/Monad/TaggedException/Internal/Throws.hs b/src/Control/Monad/TaggedException/Internal/Throws.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/TaggedException/Internal/Throws.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +#ifdef KIND_POLYMORPHIC_TYPEABLE +{-# LANGUAGE DeriveDataTypeable #-} +#endif +{-# LANGUAGE DeriveGeneric #-} +-- | +-- Module: $HEADER$ +-- Description: Data type for associating monadic value with phantom type. +-- Copyright: (c) 2009 - 2014 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: stable +-- Portability: non-portable (CPP, NoImplicitPrelude, PolyKinds, RankNTypes +-- DeriveDataTypeable, DeriveGeneric) +-- +-- Data type for associating monadic value with phantom type. In case of this +-- library it will always be associated with a type of exception it may throw. +module Control.Monad.TaggedException.Internal.Throws + ( + Throws(..) + , liftMask + ) + where + +import Control.Applicative + ( Alternative((<|>), empty, many, some) + , Applicative((<*), (<*>), (*>), pure) + ) +import Control.Monad + ( Monad((>>), (>>=), fail, return) + , MonadPlus(mplus, mzero) + ) +import Data.Functor (Functor(fmap)) +import Data.Function ((.)) +#ifdef KIND_POLYMORPHIC_TYPEABLE +import Data.Typeable (Typeable) +#endif +import GHC.Generics (Generic) + +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Trans.Class (MonadTrans(lift)) + +import Control.Monad.Catch + ( MonadCatch(catch) + , MonadMask(mask, uninterruptibleMask) + , MonadThrow(throwM) + ) +import Control.Monad.Morph (MFunctor(hoist), MMonad(embed)) + + +-- | Exception tag. +newtype Throws e m a = Throws + { hideException :: m a + -- ^ Hide one exception. + } + deriving + ( Generic +#ifdef KIND_POLYMORPHIC_TYPEABLE + , Typeable +#endif + ) + +-- | Lift @mask@ operation in to 'Throws' context. +liftMask + :: (((forall a. m a -> m a) -> m b) -> m b) + -> ((forall a. Throws e m a -> Throws e m a) -> Throws e m b) + -> Throws e m b +liftMask msk f = Throws (msk (\restore -> hideException (f (liftT restore)))) + where + liftT :: (m a -> m a) -> (Throws e m a -> Throws e m a) + liftT g (Throws m) = Throws (g m) +{-# INLINABLE liftMask #-} + +-- {{{ Instances -------------------------------------------------------------- + +instance Functor f => Functor (Throws e f) where + -- (a -> b) -> Throws e f a -> Throws e f b + fmap f (Throws ma) = Throws (fmap f ma) + +instance Applicative f => Applicative (Throws e f) where + pure = Throws . pure + Throws x <*> Throws y = Throws (x <*> y) + Throws x *> Throws y = Throws (x *> y) + Throws x <* Throws y = Throws (x <* y) + +instance Alternative f => Alternative (Throws e f) where + empty = Throws empty + Throws x <|> Throws y = Throws (x <|> y) + some (Throws ma) = Throws (some ma) + many (Throws ma) = Throws (many ma) + +instance Monad m => Monad (Throws e m) where + return = Throws . return + Throws ma >>= f = Throws (ma >>= hideException . f) + Throws ma >> Throws na = Throws (ma >> na) + fail = Throws . fail + +instance MonadPlus m => MonadPlus (Throws e m) where + mzero = Throws mzero + Throws m `mplus` Throws n = Throws (m `mplus` n) + +-- {{{ Instances: transformers ------------------------------------------------ + +instance MonadIO m => MonadIO (Throws e m) where + liftIO = Throws . liftIO + +instance MonadTrans (Throws e) where + lift = Throws + +-- }}} Instances: transformers ------------------------------------------------ + +-- {{{ Instances: mmorph ------------------------------------------------------ + +-- | Since @1.2.0.0@. +instance MFunctor (Throws e) where + -- :: Monad m => (forall a. m a -> n a) -> Throws e m b -> Throws e n b + hoist f x = Throws (f (hideException x)) + +-- | Since @1.2.0.0@. +instance MMonad (Throws e) where + -- :: Monad n + -- => (forall a. m a -> Throws e n a) + -- -> Throws e m b -> Throws e n b + embed f x = f (hideException x) + +-- }}} Instances: mmorph ------------------------------------------------------ + +-- {{{ Instances: exceptions -------------------------------------------------- + +-- | Since @2.0.0.0@. +instance MonadThrow m => MonadThrow (Throws e m) where + -- throwM :: Exception e' => e' -> Throws m a + throwM = Throws . throwM + +-- | Since @2.0.0.0@. +instance MonadCatch m => MonadCatch (Throws e m) where + -- :: Exception e' => Throws m a -> (e' -> Throws m a) -> Throws m a + catch (Throws ma) f = Throws (catch ma (hideException . f)) + +-- | Since @2.0.0.0@. +instance MonadMask m => MonadMask (Throws e m) where + -- :: ((forall a. Throws e m a -> Throws e m a) -> Throws e m b) + -- -> Throws e m b + mask = liftMask mask + + -- :: ((forall a. Throws e m a -> Throws e m a) -> Throws e m b) + -- -> Throws e m b + uninterruptibleMask = liftMask uninterruptibleMask + +-- }}} Instances: exceptions -------------------------------------------------- +-- }}} Instances -------------------------------------------------------------- diff --git a/src/Control/Monad/TaggedException/Unsafe.hs b/src/Control/Monad/TaggedException/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/TaggedException/Unsafe.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Unsafe exception tag cobinators and specific lifting +-- functions. +-- Copyright: (c) 2009 - 2014 Peter Trsko +-- License: BSD3 +-- +-- Stability: provisional +-- Portability: non-portable (NoImplicitPrelude) +-- +-- Unsafe exception tag cobinators and specific lifting functions. Import this +-- module if creating new 'MonadException' instance(s) that can not be created +-- otherwise. +-- +-- Preferably import as: +-- +-- > import qualified Control.Monad.TaggedException.Unsafe as Unsafe +module Control.Monad.TaggedException.Unsafe + ( Throws + , throwsOne + , throwsTwo + , throwsThree + , hideOne + , hideTwo + , hideThree + + , liftT1 + , liftT2 + , liftT3 + , insideT + , insideTf + , insideTf2 + , insideT2 + , insideT3 + , joinT + , joinT3 + , flipT + , embedT + + , liftMask + , liftBindLike + , liftFlipBindLike + , liftKleisliLike + ) + where + +import Data.Function ((.), ($)) +import Data.Functor (Functor(fmap)) + +import Control.Monad.TaggedException.Internal.Throws + ( Throws(Throws, hideException) + , liftMask + ) + + +-- | Construct exception tag, but without 'Control.Monad.Catch.MonadThrow' +-- restriction. +throwsOne :: m a -> Throws e m a +throwsOne = Throws + +-- | Shorthand for @'throwsOne' . 'throwsOne'@. +throwsTwo :: m a -> Throws e' (Throws e m) a +throwsTwo = Throws . Throws + +-- | Shorthand for @'throwsOne' . 'throwsOne' . 'throwsOne'@. +throwsThree :: m a -> Throws e'' (Throws e' (Throws e m)) a +throwsThree = Throws . Throws . Throws + +-- | Hide one exceptions, but without 'Control.Monad.Catch.MonadThrow' +-- restriction. +hideOne :: Throws e m a -> m a +hideOne = hideException + +-- | Hide two exceptions, but without 'Control.Monad.Catch.MonadThrow' +-- restriction. +hideTwo :: Throws e (Throws e' m) a -> m a +hideTwo = hideException . hideException + +-- | Hide three exceptions, but without 'Control.Monad.Catch.MonadThrow' +-- restriction. +hideThree :: Throws e (Throws e' (Throws e'' m)) a -> m a +hideThree = hideException . hideException . hideException + +-- | 'liftT' for functions with arity one. Isn't restricted just to +-- 'Control.Monad.Catch.MonadThrow' instances. +liftT1 + :: (m a -> m b) + -> Throws e m a -> Throws e m b +liftT1 = (Throws .) . (. hideException) + +-- | 'liftT' for functions with arity two. Isn't restricted just to +-- 'Control.Monad.Catch.MonadThrow' instances. +liftT2 + :: (m a -> m b -> m c) + -> Throws e m a -> Throws e m b -> Throws e m c +liftT2 f m n = Throws $ f (hideException m) (hideException n) + +-- | 'liftT' for functions with arity three. Isn't restricted just to +-- 'Control.Monad.Catch.MonadThrow' instances. +liftT3 + :: (m a -> m b -> m c -> m d) + -> Throws e m a -> Throws e m b -> Throws e m c -> Throws e m d +liftT3 f m n o = + Throws $ f (hideException m) (hideException n) (hideException o) + +-- | Generalized 'liftT'. +insideT + :: (m a -> m' b) + -> Throws e m a -> Throws e m' b +insideT = (Throws .) . (. hideException) + +-- | Variant 'insideT'. +insideTf + :: (Functor f) + => (f (m a) -> m' b) + -> f (Throws e m a) + -> Throws e m' b +insideTf = (Throws .) . (. fmap hideException) + +-- | Variant 'insideT'. +insideTf2 + :: (Functor f, Functor f') + => (f (f' (m a)) -> m' b) + -> f (f' (Throws e m a)) + -> Throws e m' b +insideTf2 = (Throws .) . (. fmap (fmap hideException)) + +-- | Generalized 'liftT2'. +insideT2 + :: (m1 a -> m2 b -> m3 c) + -> Throws e m1 a -> Throws e m2 b -> Throws e m3 c +insideT2 f m n = Throws $ f (hideException m) (hideException n) + +-- | Generalized 'liftT3'. +insideT3 + :: (m1 a -> m2 b -> m3 c -> m4 d) + -> Throws e m1 a -> Throws e m2 b -> Throws e m3 c -> Throws e m4 d +insideT3 f m n o = + Throws $ f (hideException m) (hideException n) (hideException o) + +-- | Join two exception tags in to one. Isn't restricted just to +-- 'Control.Monad.Catch.MonadThrow' instances. +joinT + :: Throws e (Throws e m) a + -> Throws e m a +joinT = hideException + +-- | Join three exception tags in to one. Isn't restricted just to +-- 'Control.Monad.Catch.MonadThrow' instances. +joinT3 + :: Throws e (Throws e (Throws e m)) a + -> Throws e m a +joinT3 = hideTwo + +-- | Flip two outermost exception tags. Isn't restricted just to +-- 'Control.Monad.Catch.MonadThrow' instances. +flipT + :: Throws e' (Throws e m) a + -> Throws e (Throws e' m) a +flipT = throwsTwo . hideTwo + +-- | Since @1.2.0.0@. +embedT :: (m a -> Throws e n b) -> Throws e m a -> Throws e n b +embedT = (. hideException) + +-- | Lift operations with type similar to monadic bind. In example: +-- +-- @ +-- ('Control.Monad.>>=') :: 'Control.Monad.Monad' m => m a -> (a -> m b) -> m b +-- @ +-- +-- @ +-- 'Prelude.catch' +-- :: 'System.IO.IO' a +-- -> ('Control.Exception.IOError' -> 'System.IO.IO' a) +-- -> 'System.IO.IO' a +-- @ +-- +-- @ +-- 'Control.Exception.catch' +-- :: 'Control.Exception.Exception' e +-- => 'System.IO.IO' a -> (e -> 'System.IO.IO' a) -> 'System.IO.IO' a +-- @ +-- +-- Since @1.2.0.0@. +liftBindLike + :: (m a -> (b -> m c) -> m d) + -> Throws e m a + -> (b -> Throws e m c) + -> Throws e m d +liftBindLike f x g = throwsOne $ f (hideException x) (hideException . g) + +-- | Lift operations with type similar to flipped monadic bind. In example: +-- +-- @ +-- ('Control.Monad.=<<') :: 'Control.Monad.Monad' m => (a -> m b) -> m a -> m b +-- @ +-- +-- @ +-- 'Control.Exception.handle' +-- :: 'Control.Exception.Exception' e +-- => (e -> 'System.IO.IO' a) -> 'System.IO.IO' a -> 'System.IO.IO' a +-- @ +-- +-- Since @1.2.0.0@. +liftFlipBindLike + :: ((a -> m b) -> m c -> m d) + -> (a -> Throws e m b) -> Throws e m c -> Throws e m d +liftFlipBindLike f g x = Throws $ f (hideException . g) (hideException x) + +-- | Lift klieisli composition like operations. In example: +-- +-- @ +-- ('Control.Monad.>=>') +-- :: 'Control.Monad.Monad' m => (a -> m b) -> (b -> m c) -> a -> m c +-- @ +-- +-- @ +-- ('Control.Monad.<=<') +-- :: 'Control.Monad.Monad' m => (b -> m c) -> (a -> m b) -> a -> m c +-- @ +-- +-- Since @1.2.0.0@. +liftKleisliLike + :: ((a -> m a') -> (b -> m b') -> c -> m c') + -> (a -> Throws e m a') -> (b -> Throws e m b') -> c -> Throws e m c' +liftKleisliLike f g h = Throws . f (hideException . g) (hideException . h) diff --git a/src/Control/Monad/TaggedException/Utilities.hs b/src/Control/Monad/TaggedException/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/TaggedException/Utilities.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +-- | +-- Module: $HEADER$ +-- Description: MonadExceptionUtilities class and instances. +-- Copyright: (c) 2009 - 2014 Peter Trsko. +-- License: BSD3 +-- +-- Stability: provisional +-- Portability: non-portable (NoImplicitPrelude, RankNTypes) +-- +-- Introduces 'MonadExceptionUtilities' type class that provides means for +-- overriding default implementation of functions like 'bracket'. +module Control.Monad.TaggedException.Utilities + ( + bracket + , bracket' + , bracket_ + , bracketOnError + , bracketOnError' + , finally + , finally' + ) + where + +import Control.Monad (Monad(return)) +import Control.Exception (Exception) +import Data.Function (($), const) + +import Control.Monad.Catch (MonadMask) +import qualified Control.Monad.Catch as Exceptions + +import Control.Monad.TaggedException.Core + ( liftT + , onException + , onException' + ) +import Control.Monad.TaggedException.Internal.Throws (Throws) +import qualified Control.Monad.TaggedException.Internal.Throws + as Unsafe (liftMask) + + +mask' :: MonadMask m => ((forall a. m a -> m a) -> m b) -> m b +mask' = Exceptions.mask + +mask + :: (Exception e, MonadMask m) + => ((forall a. Throws e m a -> Throws e m a) -> Throws e m b) + -> Throws e m b +mask = Unsafe.liftMask Exceptions.mask + +-- | Run computation afeter another even if exception was thrown. See also +-- 'finally'', 'onException' and 'onException''. +-- +-- Default implementation: +-- +-- > m `finally` n = mask $ \ restore -> do +-- > r <- restore m `onException` n +-- > _ <- liftT n +-- > return r +finally + :: (Exception e, MonadMask m) + => Throws e m a + -- ^ Computation to run first + -> m b + -- ^ Computation to run afterward (even if exception @e@ was raised) + -> Throws e m a + -- ^ Returns the result of the first computation +m `finally` n = mask $ \restore -> do + r <- restore m `onException` n + _ <- liftT n + return r + +-- | Run computation afeter another even if exception was thrown. See also +-- 'finally', 'onException' and 'onException''. +finally' + :: MonadMask m + => m a + -- ^ Computation to run first + -> m b + -- ^ Computation to run afterward (even if some exception was raised) + -> m a + -- ^ Returns the result of the first computation +finally' = Exceptions.finally + +-- | Run computation surrounded by acquire and release computations. The +-- release computation is executed even if \"in-between\" computation +-- raises exception. See also 'bracket'', 'bracket_', 'bracketOnError', +-- and 'bracketOnError''. +bracket + :: (Exception e, MonadMask m) + => m a + -- ^ Computation to run before + -> (a -> m b) + -- ^ Computation to run after + -> (a -> Throws e m c) + -- ^ Computation to run in-between + -> Throws e m c + -- ^ Result of the in-between computation +bracket acq rel go = mask $ \ restore -> do + x <- liftT acq + r <- restore (go x) `onException` rel x + _ <- liftT $ rel x + return r + +-- | Run computation surrounded by acquire and release computations. The +-- release computation is executed even if \"in-between\" computation +-- raises exception. See also 'bracket', 'bracket_', 'bracketOnError', and +-- 'bracketOnError''. +-- +-- Default implementation: +-- +-- > bracket' acq rel go = mask' $ \ restore -> do +-- > x <- acq +-- > r <- restore (go x) `onException'` rel x +-- > _ <- rel x +-- > return r +bracket' + :: MonadMask m + => m a + -- ^ Computation to run before + -> (a -> m b) + -- ^ Computation to run after + -> (a -> m c) + -- ^ Computation to run in-between + -> m c + -- ^ Result of the in-between computation +bracket' = Exceptions.bracket + +-- | Version of 'bracket' where \"after\" computation is executed only if +-- \"in-between\" computation raises exception. +-- +-- Default implementation: +-- +-- > bracketOnError acq rel go = mask $ \ restore -> do +-- > x <- liftT acq +-- > restore (go x) `onException` rel x +bracketOnError + :: (Exception e, MonadMask m) + => m a + -- ^ Computation to run before + -> (a -> m b) + -- ^ Computation to run after if an exception was raised + -> (a -> Throws e m c) + -- ^ Computation to run in-between + -> Throws e m c + -- ^ Result of the in-between computation +bracketOnError acq rel go = mask $ \ restore -> do + x <- liftT acq + restore (go x) `onException` rel x + +-- | Version of 'bracket' where \"after\" computation is executed only if +-- \"in-between\" computation raises exception. +-- +-- Default implementation: +-- +-- > bracketOnError' acq rel go = mask' $ \ restore -> do +-- > x <- liftT acq +-- > restore (go x) `onException'` rel x +bracketOnError' + :: MonadMask m + => m a + -- ^ Computation to run before + -> (a -> m b) + -- ^ Computation to run after if an exception was raised + -> (a -> m c) + -- ^ Computation to run in-between + -> m c + -- ^ Result of the in-between computation +bracketOnError' acq rel go = mask' $ \ restore -> do + x <- acq + restore (go x) `onException'` rel x + +-- | Variant of 'bracket'. +-- +-- > bracket_ acq rel go = bracket acq (const rel) (const go) +bracket_ + :: (Exception e, MonadMask m) + => m a + -- ^ Computation to run before + -> m b + -- ^ Computation to run after + -> Throws e m c + -- ^ Computation to run in-between + -> Throws e m c + -- ^ Result of the in-between computation +bracket_ acq rel go = bracket acq (const rel) (const go) diff --git a/tagged-exception-core.cabal b/tagged-exception-core.cabal new file mode 100644 --- /dev/null +++ b/tagged-exception-core.cabal @@ -0,0 +1,84 @@ +Name: tagged-exception-core +Version: 2.0.0.0 +Synopsis: Reflect exceptions using phantom types. +Description: + This library provides interface similar to /extensible-exceptions/. It + introduces @Throws@ monad transformer that uses phantom type to tag code that + may raise exception. Intention is to make exceptions explicit and to enforce + exception handling. +Homepage: https://github.com/trskop/tagged-exception +Bug-reports: https://github.com/trskop/tagged-exception/issues +Copyright: Copyright (c) 2009 - 2014, Peter Trsko +License: BSD3 +License-file: LICENSE +Author: Peter Trsko +Maintainer: peter.trsko@gmail.com +Category: + Control + , Error Handling + , Exceptions + , Failure + , Monad + , Monads + , Phantom Types + +Build-type: Simple +Cabal-version: >= 1.10 +-- Tested-with: +Extra-source-files: ChangeLog.md + +Flag pedantic + Description: + Pass additional flags, including -Werror, to GHC during compilation. + Default: False + Manual: True + +Flag base-ge-4_2 + Description: Depend on base >= 4.2 && < 4.6. + Default: False + +Library + Hs-source-dirs: src + Exposed-modules: + Control.Monad.TaggedException + , Control.Monad.TaggedException.Core + , Control.Monad.TaggedException.Hidden + , Control.Monad.TaggedException.Internal.Throws + , Control.Monad.TaggedException.Unsafe + , Control.Monad.TaggedException.Utilities + + Default-language: Haskell2010 + + if flag(base-ge-4_2) + Build-depends: + base >= 4.2 && < 4.8 + else + Build-depends: + base >= 4 && < 4.2 + , extensible-exceptions >= 0.1.1.3 + Build-depends: + exceptions > 0.6 && < 0.7 + -- ^ Interface of this package changed a lot between minor versions, + -- therefore trying conservative approach. Dependency introduced in + -- tagged-exception-core-2.0.0.0. + , transformers >= 0.2 && < 0.4 + , mmorph >= 1.0.0 && < 1.1 + -- ^ Dependency introduced in tagged-exception-core-1.2.0.0. + + if impl(ghc >= 7.8.1) + CPP-options: -DKIND_POLYMORPHIC_TYPEABLE + + GHC-options: -Wall + if impl(GHC >= 6.8) + GHC-options: -fwarn-tabs + if impl(GHC >= 7.2) + GHC-options: -fwarn-identities + if flag(pedantic) + GHC-options: + -fwarn-implicit-prelude + -fwarn-missing-import-lists + -Werror + +source-repository head + type: git + location: git://github.com/trskop/tagged-exception.git