diff --git a/Control/Monad/Exception.hs b/Control/Monad/Exception.hs --- a/Control/Monad/Exception.hs +++ b/Control/Monad/Exception.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-| A Monad Transformer for explicitly typed checked exceptions. @@ -41,39 +36,61 @@ > eval `catch` \ (e::DivideByZero) -> return (-1) :: Throws SumOverflow l => Expr -> EM l Double > runEM(eval `catch` \ (e::SomeException) -> return (-1)) > :: Expr -> Double +-} -/Notes about type errors and exception hierarchies/ +module Control.Monad.Exception ( +-- * Important trivia +-- ** Hierarchies of Exceptions +-- $hierarchies - * A type error of the form: +-- ** Unchecked and unexplicit exceptions +-- *** Unchecked exceptions +-- $unchecked -> No instance for (UncaughtException MyException) -> arising from a use of `g' at examples/docatch.hs:21:32-35 -> Possible fix: -> add an instance declaration for (UncaughtException MyException) -> In the expression: g () +-- *** Unexplicit exceptions +-- $unexplicit -is the type checker saying: +-- ** Stack Traces +-- $stacktraces -\"hey, you are trying to run a computation which throws a @MyException@ without handling it, and I won't let you\" +-- ** Understanding GHC errors +-- $errors -Either handle it or declare @MyException@ as an 'UncaughtException'. +-- * The EM monad + EM, tryEM, runEM, runEMParanoid, - * A type error of the form: +-- * The EMT monad transformer + EMT(..), CallTrace, tryEMT, runEMT, runEMTParanoid, AnyException, UncaughtException, -> Overlapping instances for Throws MyException (Caught e NoExceptions) -> arising from a use of `g' at docatch.hs:24:3-6 -> Matching instances: -> instance (Throws e l) => Throws e (Caught e' l) -> -- Defined at ../Control/Monad/Exception/Throws.hs:46:9-45 -> instance (Exception e) => Throws e (Caught e l) -> -- Defined at ../Control/Monad/Exception/Throws.hs:47:9-44 -> (The choice depends on the instantiation of `e' -> ... +-- ** The Throws type class + Throws, Caught, - is due to an exception handler for @MyException@ -missing a type annotation to pin down the type of the exception. +-- ** The Try type class for absorbing other failure types + Try(..), NothingException(..), - * If your sets of exceptions are hierarchical then you need to +-- * Exception primitives + throw, rethrow, Control.Monad.Exception.Base.catch, Control.Monad.Exception.Base.catchWithSrcLoc, + finally, onException, bracket, wrapException, + + showExceptionWithTrace, + FailException(..), MonadZeroException(..), + +-- * Reexports + Exception(..), SomeException(..), Typeable(..), + MonadFailure(..), WrapFailure(..), + MonadLoc(..), withLocTH +) where + +import Control.Exception (Exception(..), SomeException(..)) +import Control.Monad.Exception.Base +import Control.Monad.Exception.Catch +import Control.Monad.Exception.Throws +import Control.Monad.Failure +import Control.Monad.Loc +import Data.Typeable + +{- $hierarchies + If your sets of exceptions are hierarchical then you need to teach 'Throws' about the hierarchy. > -- TopException @@ -82,18 +99,39 @@ > -- MidException > instance Throws ChildException (Caught MidException l) -- | > instance Throws ChildException (Caught TopException l) -- | - > -- ChildException +> -- ChildException +-} +{- $unchecked +An exception @E@ can be declared as unchecked by making @E@ an instance of + 'UncaughtException'. +> instance UncaughtException E - * Stack traces are provided via the "MonadLoc" package. + @E@ will still appear in the list of exceptions thrown + by a computation but 'runEMT' will not complain if @E@ escapes the computation + being run. + +Also, 'tryEMT' allows you to run a computation regardless of the exceptions it throws. +-} + +{- $unexplicit +An exception @E@ can be made unexplicit: @E@ will not appear in the list + of exceptions. To do so include the following instance in your code: + +> instance Throws E l + +-} + +{- $stacktraces + Stack traces are provided via the "MonadLoc" package. All you need to do is add the following pragma at the top of your Haskell source files and use do-notation: -> {-# OPTIONS_GHC -F -pgmF MonadLoc #-} +> { # OPTIONS_GHC -F -pgmF MonadLoc # } Only statements in do blocks appear in the stack trace. -* Example: + Example: > f () = do throw MyException > g a = do f a @@ -112,254 +150,35 @@ > main, Main(example.hs): (4,16) -} -module Control.Monad.Exception ( --- * The EM monad - EM, tryEM, runEM, runEMParanoid, --- * The EMT monad transformer - EMT, CallTrace, tryEMT, runEMT, runEMTParanoid, - --- * Exception primitives - throw, rethrow, Control.Monad.Exception.catch, Control.Monad.Exception.catchWithSrcLoc, - finally, onException, bracket, wrapException, - - showExceptionWithTrace, - FailException(..), MonadZeroException(..), - --- * The Try class for absorbing other error monads - Try(..), NothingException(..), - --- * Reexports - Exception(..), SomeException(..), Typeable(..), - MonadFailure(..), - Throws, Caught, UncaughtException, - withLoc, withLocTH, - -) where - -import Control.Applicative -import qualified Control.Exception as CE -import Control.Monad.Identity -import Control.Monad.Exception.Catch -import Control.Monad.Fix -import Control.Monad.Trans -import Control.Monad.Cont.Class -import Control.Monad.RWS.Class -import Control.Monad.Loc -import Control.Monad.Failure -import Data.Monoid -import Data.Typeable -import Text.PrettyPrint -import Prelude hiding (catch) - --- | A monad of explicitly typed, checked exceptions -type EM l = EMT l Identity - -mapLeft :: (a -> b) -> Either a r -> Either b r -mapLeft f (Left x) = Left (f x) -mapLeft _ (Right x) = Right x - --- | Run a computation explicitly handling exceptions -tryEM :: EM (AnyException l) a -> Either SomeException a -tryEM = runIdentity . tryEMT - --- | Run a safe computation -runEM :: EM NoExceptions a -> a -runEM = runIdentity . runEMT - --- | Run a computation checking even unchecked (@UncaughtExceptions@) exceptions -runEMParanoid :: EM ParanoidMode a -> a -runEMParanoid = runIdentity . runEMTParanoid - -type CallTrace = [String] - -newtype EMT l m a = EMT {unEMT :: m (Either (CallTrace, CheckedException l) a)} - -type AnyException = Caught SomeException - --- | Run a computation explicitly handling exceptions -tryEMT :: Monad m => EMT (AnyException l) m a -> m (Either SomeException a) -tryEMT (EMT m) = mapLeft (checkedException.snd) `liftM` m - -runEMT_gen :: forall l m a . Monad m => EMT l m a -> m a -runEMT_gen (EMT m) = m >>= \x -> - case x of - Right x -> return x - Left (loc,e) -> error (showExceptionWithTrace loc (checkedException e)) - --- | Run a safe computation -runEMT :: Monad m => EMT NoExceptions m a -> m a -runEMT = runEMT_gen - --- | Run a safe computation checking even unchecked (@UncaughtException@) exceptions -runEMTParanoid :: Monad m => EMT ParanoidMode m a -> m a -runEMTParanoid = runEMT_gen - -instance Monad m => Functor (EMT l m) where - fmap f emt = EMT $ do - v <- unEMT emt - case v of - Left e -> return (Left e) - Right x -> return (Right (f x)) - -instance Monad m => Monad (EMT l m) where - return = EMT . return . Right - - fail s = EMT $ return $ Left ([], CheckedException $ toException $ FailException s) - - emt >>= f = EMT $ do - v <- unEMT emt - case v of - Left e -> return (Left e) - Right x -> unEMT (f x) - -instance Monad m => Applicative (EMT l m) where - pure = return - (<*>) = ap - -instance (Exception e, Throws e l, Monad m) => MonadFailure e (EMT l m) where - failure = throw - -instance (Exception e, Monad m) => MonadCatch e (EMT (Caught e l) m) (EMT l m) where - catchWithSrcLoc = Control.Monad.Exception.catchWithSrcLoc - catch = Control.Monad.Exception.catch - -instance Monad m => MonadLoc (EMT l m) where - withLoc loc (EMT emt) = EMT $ do - current <- emt - case current of - (Left (tr, a)) -> return (Left (loc:tr, a)) - _ -> return current - --- | The throw primitive -throw :: (Exception e, Throws e l, Monad m) => e -> EMT l m a -throw = EMT . return . (\e -> Left ([],e)) . CheckedException . toException - --- | Rethrow an exception keeping the call trace -rethrow :: (Throws e l, Monad m) => CallTrace -> e -> EMT l m a -rethrow callt = EMT . return . (\e -> Left (callt,e)) . CheckedException . toException - - --- | The catch primitive -catch :: (Exception e, Monad m) => EMT (Caught e l) m a -> (e -> EMT l m a) -> EMT l m a -catch emt h = Control.Monad.Exception.catchWithSrcLoc emt (\_ -> h) - --- | Like 'Control.Monad.Exception.catch' but makes the call trace available -catchWithSrcLoc :: (Exception e, Monad m) => EMT (Caught e l) m a -> (CallTrace -> e -> EMT l m a) -> EMT l m a -catchWithSrcLoc emt h = EMT $ do - v <- unEMT emt - case v of - Right x -> return (Right x) - Left (trace, CheckedException e) -> case fromException e of - Nothing -> return (Left (trace,CheckedException e)) - Just e' -> unEMT (h trace e') - - --- | Sequence two computations discarding the result of the second one. --- If the first computation rises an exception, the second computation is run --- and then the exception is rethrown. -finally :: Monad m => EMT l m a -> EMT l m b -> EMT l m a -finally m sequel = do { v <- m `onException` sequel; sequel; return v} - - --- | Like finally, but performs the second computation only when the first one --- rises an exception -onException :: Monad m => EMT l m a -> EMT l m b -> EMT l m a -onException (EMT m) (EMT sequel) = EMT $ do - ev <- m - case ev of - Left{} -> do { sequel; return ev} - Right{} -> return ev - -bracket :: Monad m => EMT l m a -- ^ acquire resource - -> (a -> EMT l m b) -- ^ release resource - -> (a -> EMT l m c) -- ^ computation - -> EMT l m c -bracket acquire release run = do { k <- acquire; run k `finally` release k } - --- | Capture an exception e, wrap it, and rethrow. --- Keeps the original monadic call trace. -wrapException :: (Exception e, Throws e' l, Monad m) => EMT (Caught e l) m a -> (e -> e') -> EMT l m a -wrapException m mkE = m `Control.Monad.Exception.catchWithSrcLoc` \loc e -> rethrow loc (mkE e) - -showExceptionWithTrace :: Exception e => [String] -> e -> String -showExceptionWithTrace [] e = show e -showExceptionWithTrace trace e = render$ - text (show e) $$ - text " in" <+> (vcat (map text $ reverse trace)) - -instance (Throws MonadZeroException l) => MonadPlus (EM l) where - mzero = throw MonadZeroException - mplus emt1 emt2 = EMT$ do - v1 <- unEMT emt1 - case v1 of - Left _ -> unEMT emt2 - Right _ -> return v1 - -instance MonadTrans (EMT l) where lift = EMT . liftM Right - -instance MonadFix m => MonadFix (EMT l m) where - mfix f = EMT $ mfix $ \a -> unEMT $ f $ case a of - Right r -> r - _ -> error "empty fix argument" -instance UncaughtException SomeException - -instance (Throws SomeException l, MonadIO m) => MonadIO (EMT l m) where - liftIO m = EMT (liftIO m') where - m' = liftM Right m - `CE.catch` - \(e::SomeException) -> return (Left ([], CheckedException e)) - - --- ----------------------------------------------- --- The Try class for absorbing other error monads --- ----------------------------------------------- -data NothingException = NothingException deriving (Typeable, Show) -instance Exception NothingException - -class Try m l where try :: Monad m' => m a -> EMT l m' a -instance Throws NothingException l => Try Maybe l where try = maybe (throw NothingException) return -instance (Exception e, Throws e l) => Try (Either e) l where try = either throw return - -instance (Monad m, Try m l) => Try (EMT l m) l where try = join . fmap (EMT . return) .try . unEMT - --- ----------- --- Exceptions --- ----------- - --- | @FailException@ is thrown by Monad 'fail' -data FailException = FailException String deriving (Show, Typeable) -instance Exception FailException +{- $errors +A type error of the form: --- | @MonadZeroException@ is thrown by MonadPlus 'mzero' -data MonadZeroException = MonadZeroException deriving (Show, Typeable) -instance Exception MonadZeroException +> No instance for (UncaughtException MyException) +> arising from a use of `g' at examples/docatch.hs:21:32-35 +> Possible fix: +> add an instance declaration for (UncaughtException MyException) +> In the expression: g () --- ------------------ --- mtl boilerplate --- ------------------ +is the type checker saying: -instance MonadCont m => MonadCont (EMT l m) where - callCC f = EMT $ callCC $ \c -> unEMT (f (\a -> EMT $ c (Right a))) +\"hey, you are trying to run a computation which throws a @MyException@ without handling it, and I won't let you\" -instance MonadReader r m => MonadReader r (EMT l m) where - ask = lift ask - local f m = EMT (local f (unEMT m)) +Either handle it or declare @MyException@ as an 'UncaughtException'. -instance MonadState s m => MonadState s (EMT l m) where - get = lift get - put = lift . put +A type error of the form: -instance (Monoid w, MonadWriter w m) => MonadWriter w (EMT l m) where - tell = lift . tell - listen m = EMT $ do - (res, w) <- listen (unEMT m) - return (fmap (\x -> (x,w)) res) - pass m = EMT $ pass $ do - a <- unEMT m - case a of - Left l -> return (Left l, id) - Right (r,f) -> return (Right r, f) +> Overlapping instances for Throws MyException (Caught e NoExceptions) +> arising from a use of `g' at docatch.hs:24:3-6 +> Matching instances: +> instance (Throws e l) => Throws e (Caught e' l) +> -- Defined at ../Control/Monad/Exception/Throws.hs:46:9-45 +> instance (Exception e) => Throws e (Caught e l) +> -- Defined at ../Control/Monad/Exception/Throws.hs:47:9-44 +> (The choice depends on the instantiation of `e' +> ... -instance (Monoid w, MonadRWS r w s m) => MonadRWS r w s (EMT l m) +is due to an exception handler for @MyException@ +missing a type annotation to pin down the type of the exception. +-} diff --git a/Control/Monad/Exception/Base.hs b/Control/Monad/Exception/Base.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Exception/Base.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} + +{-| +A Monad Transformer for explicitly typed checked exceptions. + +The exceptions thrown by a computation are inferred by the typechecker +and appear in the type signature of the computation as 'Throws' constraints. + +Exceptions are defined using the extensible exceptions framework of Marlow (documented in "Control.Exception"): + + * /An Extensible Dynamically-Typed Hierarchy of Exceptions/, by Simon Marlow, in /Haskell '06/. + + /Example/ + + > data DivideByZero = DivideByZero deriving (Show, Typeable) + > data SumOverflow = SumOverflow deriving (Show, Typeable) + + > instance Exception DivideByZero + > instance Exception SumOverflow + + > data Expr = Add Expr Expr | Div Expr Expr | Val Double + + > eval (Val x) = return x + > eval (Add a1 a2) = do + > v1 <- eval a1 + > v2 <- eval a2 + > let sum = v1 + v2 + > if sum < v1 || sum < v2 then throw SumOverflow else return sum + > eval (Div a1 a2) = do + > v1 <- eval a1 + > v2 <- eval a2 + > if v2 == 0 then throw DivideByZero else return (v1 / v2) + + GHCi infers the following types + + > eval :: (Throws DivideByZero l, Throws SumOverflow l) => Expr -> EM l Double + > eval `catch` \ (e::DivideByZero) -> return (-1) :: Throws SumOverflow l => Expr -> EM l Double + > runEM(eval `catch` \ (e::SomeException) -> return (-1)) + > :: Expr -> Double +-} +module Control.Monad.Exception.Base where + +import Control.Applicative +import Control.Monad.Exception.Catch +import Control.Monad.Loc +import Control.Monad.Failure.Class +import Control.Monad.Fix +import Data.Typeable +import Text.PrettyPrint +import Prelude hiding (catch) + +type CallTrace = [String] + +-- | A Monad Transformer for explicitly typed checked exceptions. +newtype EMT l m a = EMT {unEMT :: m (Either (CallTrace, CheckedException l) a)} + +type AnyException = Caught SomeException + +-- | Run a computation explicitly handling exceptions +tryEMT :: Monad m => EMT (AnyException l) m a -> m (Either SomeException a) +tryEMT (EMT m) = mapLeft (checkedException.snd) `liftM` m + +runEMT_gen :: forall l m a . Monad m => EMT l m a -> m a +runEMT_gen (EMT m) = m >>= \x -> + case x of + Right x -> return x + Left (loc,e) -> error (showExceptionWithTrace loc (checkedException e)) + +data NoExceptions +data ParanoidMode + +-- | Run a safe computation +runEMT :: Monad m => EMT NoExceptions m a -> m a +runEMT = runEMT_gen + +-- | Run a safe computation checking even unchecked ('UncaughtException') exceptions +runEMTParanoid :: Monad m => EMT ParanoidMode m a -> m a +runEMTParanoid = runEMT_gen + +instance Monad m => Functor (EMT l m) where + fmap f emt = EMT $ do + v <- unEMT emt + case v of + Left e -> return (Left e) + Right x -> return (Right (f x)) + +instance Monad m => Monad (EMT l m) where + return = EMT . return . Right + + fail s = EMT $ return $ Left ([], CheckedException $ toException $ FailException s) + + emt >>= f = EMT $ do + v <- unEMT emt + case v of + Left e -> return (Left e) + Right x -> unEMT (f x) + +instance Monad m => Applicative (EMT l m) where + pure = return + (<*>) = ap + +instance (Exception e, Throws e l, Monad m) => MonadFailure e (EMT l m) where + failure = throw + +instance (Exception e, Throws e l, Monad m) => WrapFailure e (EMT l m) where + wrapFailure mkE m + = EMT $ do + v <- unEMT m + case v of + Right _ -> return v + Left (loc, CheckedException (SomeException e)) + -> return $ Left (loc, CheckedException $ toException $ mkE e) + +instance (Exception e, Monad m) => MonadCatch e (EMT (Caught e l) m) (EMT l m) where + catchWithSrcLoc = Control.Monad.Exception.Base.catchWithSrcLoc + catch = Control.Monad.Exception.Base.catch + +instance Monad m => MonadLoc (EMT l m) where + withLoc loc (EMT emt) = EMT $ do + current <- withLoc loc emt + case current of + (Left (tr, a)) -> return (Left (loc:tr, a)) + _ -> return current + +instance MonadFix m => MonadFix (EMT l m) where + mfix f = EMT $ mfix $ \a -> unEMT $ f $ case a of + Right r -> r + _ -> error "empty fix argument" + +-- | The throw primitive +throw :: (Exception e, Throws e l, Monad m) => e -> EMT l m a +throw = EMT . return . (\e -> Left ([],e)) . CheckedException . toException + +-- | Rethrow an exception keeping the call trace +rethrow :: (Throws e l, Monad m) => CallTrace -> e -> EMT l m a +rethrow callt = EMT . return . (\e -> Left (callt,e)) . CheckedException . toException + + +-- | The catch primitive +catch :: (Exception e, Monad m) => EMT (Caught e l) m a -> (e -> EMT l m a) -> EMT l m a +catch emt h = Control.Monad.Exception.Base.catchWithSrcLoc emt (\_ -> h) + +-- | Like 'Control.Monad.Exception.Base.catch' but makes the call trace available +catchWithSrcLoc :: (Exception e, Monad m) => EMT (Caught e l) m a -> (CallTrace -> e -> EMT l m a) -> EMT l m a +catchWithSrcLoc emt h = EMT $ do + v <- unEMT emt + case v of + Right x -> return (Right x) + Left (trace, CheckedException e) -> case fromException e of + Nothing -> return (Left (trace,CheckedException e)) + Just e' -> unEMT (h trace e') + + +-- | Sequence two computations discarding the result of the second one. +-- If the first computation rises an exception, the second computation is run +-- and then the exception is rethrown. +finally :: Monad m => EMT l m a -> EMT l m b -> EMT l m a +finally m sequel = do { v <- m `onException` sequel; sequel; return v} + + +-- | Like finally, but performs the second computation only when the first one +-- rises an exception +onException :: Monad m => EMT l m a -> EMT l m b -> EMT l m a +onException (EMT m) (EMT sequel) = EMT $ do + ev <- m + case ev of + Left{} -> do { sequel; return ev} + Right{} -> return ev + +bracket :: Monad m => EMT l m a -- ^ acquire resource + -> (a -> EMT l m b) -- ^ release resource + -> (a -> EMT l m c) -- ^ computation + -> EMT l m c +bracket acquire release run = do { k <- acquire; run k `finally` release k } + +-- | Capture an exception e, wrap it, and rethrow. +-- Keeps the original monadic call trace. +wrapException :: (Exception e, Throws e' l, Monad m) => (e -> e') -> EMT (Caught e l) m a -> EMT l m a +wrapException mkE m = m `Control.Monad.Exception.Base.catchWithSrcLoc` \loc e -> rethrow loc (mkE e) + +showExceptionWithTrace :: Exception e => [String] -> e -> String +showExceptionWithTrace [] e = show e +showExceptionWithTrace trace e = render$ + text (show e) $$ + text " in" <+> (vcat (map text $ reverse trace)) +{- +-} + +-- | Uncaught Exceptions model unchecked exceptions +-- +-- In order to declare an unchecked exception @E@, +-- all that is needed is to make @e@ an instance of 'UncaughtException' +-- +-- > instance UncaughtException E +-- +-- Note that declaring an exception E as unchecked does not automatically +-- turn its children as unchecked too. This is a shortcoming of the current encoding. +-- +-- If that is what you want, then declare E as unchecked and unexplicit +-- using an instance of 'Throws': +-- +-- > instance Throws E l + +class Exception e => UncaughtException e +instance UncaughtException e => Throws e NoExceptions +instance UncaughtException SomeException + +-- --------------- +-- The EM Monad +-- --------------- + +-- | A monad of explicitly typed, checked exceptions +type EM l = EMT l Identity + +-- | Run a computation explicitly handling exceptions +tryEM :: EM (AnyException l) a -> Either SomeException a +tryEM = runIdentity . tryEMT + +-- | Run a safe computation +runEM :: EM NoExceptions a -> a +runEM = runIdentity . runEMT + +-- | Run a computation checking even unchecked (@UncaughtExceptions@) exceptions +runEMParanoid :: EM ParanoidMode a -> a +runEMParanoid = runIdentity . runEMTParanoid + +newtype Identity a = Identity{runIdentity::a} deriving (Eq, Ord, Show) +instance Monad Identity where + return = Identity + Identity a >>= f = f a + +-- ----------------------------------------------- +-- The Try class for absorbing other error monads +-- ----------------------------------------------- +data NothingException = NothingException deriving (Typeable, Show) +instance Exception NothingException + +class Try m l where + {- | The purpose of 'try' is to combine 'EMT' with other failure handling data types. + 'try' accepts a failing computation and turns it into an 'EMT' computation. + The instances provided allow you to 'try' on 'Maybe' and 'Either' computations. + -} + try :: Monad m' => m a -> EMT l m' a + +instance Throws NothingException l => Try Maybe l where try = maybe (throw NothingException) return +instance (Exception e, Throws e l) => Try (Either e) l where try = either throw return + +instance (Monad m, Try m l) => Try (EMT l m) l where try = join . fmap (EMT . return) .try . unEMT + +-- ----------- +-- Exceptions +-- ----------- + +-- | @FailException@ is thrown by Monad 'fail' +data FailException = FailException String deriving (Show, Typeable) +instance Exception FailException + +-- | @MonadZeroException@ is thrown by MonadPlus 'mzero' +data MonadZeroException = MonadZeroException deriving (Show, Typeable) +instance Exception MonadZeroException + + +-- other + +mapLeft :: (a -> b) -> Either a r -> Either b r +mapLeft f (Left x) = Left (f x) +mapLeft _ (Right x) = Right x diff --git a/Control/Monad/Exception/Catch.hs b/Control/Monad/Exception/Catch.hs --- a/Control/Monad/Exception/Catch.hs +++ b/Control/Monad/Exception/Catch.hs @@ -19,21 +19,6 @@ ) where import Control.Monad -#if TRANSFORMERS -import Control.Monad.Trans.Error -import Control.Monad.Trans.List -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State -import Control.Monad.Trans.Writer -import Control.Monad.Trans.RWS -#else -import Control.Monad.Error -import Control.Monad.List -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Control.Monad.RWS -#endif #if __GLASGOW_HASKELL__ < 610 import Control.Exception.Extensible (Exception(..), SomeException) @@ -42,7 +27,6 @@ import Control.Exception (Exception(..), SomeException) import qualified Control.Exception #endif -import Data.Monoid import Control.Monad.Exception.Throws @@ -58,17 +42,3 @@ -- Throw and Catch instances for the Either and ErrorT monads -- ----------------------------------------------------------- -instance (Error e) => MonadCatch e (Either e) (Either e) where catch m h = either h Right m -instance (Error e, Monad m) => MonadCatch e (ErrorT e m) (ErrorT e m) where catch = catchError - - --- Instances for transformers (requires undecidable instances in some cases) --- ------------------------------------------------------------------------- -instance MonadCatch e m m' => MonadCatch e (ListT m) (ListT m') where catch (ListT m) h = ListT (catch m (runListT . h)) -instance MonadCatch e m m' => MonadCatch e (ReaderT r m) (ReaderT r m') where catch (ReaderT m) h = ReaderT (\s -> catch (m s) ((`runReaderT` s) . h)) - -instance (Monoid w, MonadCatch e m m') => MonadCatch e (WriterT w m) (WriterT w m') where catch (WriterT m) h = WriterT (catch m (runWriterT . h)) - -instance MonadCatch e m m' => MonadCatch e (StateT s m) (StateT s m') where catch (StateT m) h = StateT (\s -> catch (m s) ((`runStateT` s) . h)) - -instance (Monoid w, MonadCatch e m m') => MonadCatch e (RWST r w s m) (RWST r w s m') where catch (RWST m) h = RWST (\r s -> catch (m r s) ((\m -> runRWST m r s) . h)) diff --git a/Control/Monad/Exception/MonadsFD.hs b/Control/Monad/Exception/MonadsFD.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Exception/MonadsFD.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE PackageImports #-} + +-- | 'EMT' liftings for the classes in the monads-fd package +module Control.Monad.Exception.MonadsFD (module Control.Monad.Exception, Control.Monad.Exception.catch + ) where + +import qualified Control.Exception as CE + +import qualified Control.Monad.Exception +import Control.Monad.Exception hiding (catch) +import Control.Monad.Exception.Catch +import Control.Monad.Exception.Throws +import "monads-fd" Control.Monad.Cont.Class +import "monads-fd" Control.Monad.RWS.Class + +import Control.Monad +import "transformers" Control.Monad.Trans + +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.State (StateT(..)) +import Control.Monad.Trans.Writer (WriterT(..)) +import Control.Monad.Trans.RWS (RWST(..)) + +import Data.Monoid +import Prelude hiding (catch) + +instance (Throws MonadZeroException l) => MonadPlus (EM l) where + mzero = throw MonadZeroException + mplus emt1 emt2 = EMT$ do + v1 <- unEMT emt1 + case v1 of + Left _ -> unEMT emt2 + Right _ -> return v1 + + +instance MonadTrans (EMT l) where lift = EMT . liftM Right + +instance (Throws SomeException l, MonadIO m) => MonadIO (EMT l m) where + liftIO m = EMT (liftIO m') where + m' = liftM Right m + `CE.catch` + \(e::SomeException) -> return (Left ([], CheckedException e)) + +instance MonadCont m => MonadCont (EMT l m) where + callCC f = EMT $ callCC $ \c -> unEMT (f (\a -> EMT $ c (Right a))) + +instance MonadReader r m => MonadReader r (EMT l m) where + ask = lift ask + local f m = EMT (local f (unEMT m)) + +instance MonadState s m => MonadState s (EMT l m) where + get = lift get + put = lift . put + +instance (Monoid w, MonadWriter w m) => MonadWriter w (EMT l m) where + tell = lift . tell + listen m = EMT $ do + (res, w) <- listen (unEMT m) + return (fmap (\x -> (x,w)) res) + pass m = EMT $ pass $ do + a <- unEMT m + case a of + Left l -> return (Left l, id) + Right (r,f) -> return (Right r, f) + +instance (Monoid w, MonadRWS r w s m) => MonadRWS r w s (EMT l m) + + +-- MonadCatch Instances +-- ------------------------------------------------------------------------- +-- instance (Error e) => MonadCatch e (Either e) (Either e) where catch m h = either h Right m +instance (Error e, Monad m) => MonadCatch e (ErrorT e m) (ErrorT e m) where catch = catchError + +instance MonadCatch e m m' => MonadCatch e (ListT m) (ListT m') where catch (ListT m) h = ListT (catch m (runListT . h)) +instance MonadCatch e m m' => MonadCatch e (ReaderT r m) (ReaderT r m') where catch (ReaderT m) h = ReaderT (\s -> catch (m s) ((`runReaderT` s) . h)) + +instance (Monoid w, MonadCatch e m m') => MonadCatch e (WriterT w m) (WriterT w m') where catch (WriterT m) h = WriterT (catch m (runWriterT . h)) + +instance MonadCatch e m m' => MonadCatch e (StateT s m) (StateT s m') where catch (StateT m) h = StateT (\s -> catch (m s) ((`runStateT` s) . h)) + +instance (Monoid w, MonadCatch e m m') => MonadCatch e (RWST r w s m) (RWST r w s m') where catch (RWST m) h = RWST (\r s -> catch (m r s) ((\m -> runRWST m r s) . h)) diff --git a/Control/Monad/Exception/Mtl.hs b/Control/Monad/Exception/Mtl.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Exception/Mtl.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | 'EMT' liftings for the classes in the Monad Transformer Library +module Control.Monad.Exception.Mtl (module Control.Monad.Exception, Control.Monad.Exception.catch) where + +import qualified Control.Exception as CE + +import qualified Control.Monad.Exception +import Control.Monad.Exception hiding (catch) +import Control.Monad.Exception.Catch as Catch +import Control.Monad.Exception.Throws +import "mtl" Control.Monad.Cont.Class +import "mtl" Control.Monad.Error +import "mtl" Control.Monad.List +import "mtl" Control.Monad.Reader +import "mtl" Control.Monad.State +import "mtl" Control.Monad.Writer +import "mtl" Control.Monad.RWS +import Data.Monoid +import Prelude hiding (catch) + +instance (Throws MonadZeroException l) => MonadPlus (EM l) where + mzero = throw MonadZeroException + mplus emt1 emt2 = EMT$ do + v1 <- unEMT emt1 + case v1 of + Left _ -> unEMT emt2 + Right _ -> return v1 + + +instance MonadTrans (EMT l) where lift = EMT . liftM Right + +instance (Throws SomeException l, MonadIO m) => MonadIO (EMT l m) where + liftIO m = EMT (liftIO m') where + m' = liftM Right m + `CE.catch` + \(e::SomeException) -> return (Left ([], CheckedException e)) + +instance MonadCont m => MonadCont (EMT l m) where + callCC f = EMT $ callCC $ \c -> unEMT (f (\a -> EMT $ c (Right a))) + +instance MonadReader r m => MonadReader r (EMT l m) where + ask = lift ask + local f m = EMT (local f (unEMT m)) + +instance MonadState s m => MonadState s (EMT l m) where + get = lift get + put = lift . put + +instance (Monoid w, MonadWriter w m) => MonadWriter w (EMT l m) where + tell = lift . tell + listen m = EMT $ do + (res, w) <- listen (unEMT m) + return (fmap (\x -> (x,w)) res) + pass m = EMT $ pass $ do + a <- unEMT m + case a of + Left l -> return (Left l, id) + Right (r,f) -> return (Right r, f) + +instance (Monoid w, MonadRWS r w s m) => MonadRWS r w s (EMT l m) + + + +-- MonadCatch Instances +-- ------------------------------------------------------------------------- + +-- Commented out due to the problem of duplicated Monad instances for Either +-- instance (Error e) => MonadCatch e (Either e) (Either e) where catch m h = either h Right m +instance (Error e, Monad m) => MonadCatch e (ErrorT e m) (ErrorT e m) where catch = catchError + +instance MonadCatch e m m' => MonadCatch e (ListT m) (ListT m') where catch (ListT m) h = ListT (Catch.catch m (runListT . h)) +instance MonadCatch e m m' => MonadCatch e (ReaderT r m) (ReaderT r m') where catch (ReaderT m) h = ReaderT (\s -> Catch.catch (m s) ((`runReaderT` s) . h)) + +instance (Monoid w, MonadCatch e m m') => MonadCatch e (WriterT w m) (WriterT w m') where catch (WriterT m) h = WriterT (Catch.catch m (runWriterT . h)) + +instance MonadCatch e m m' => MonadCatch e (StateT s m) (StateT s m') where catch (StateT m) h = StateT (\s -> Catch.catch (m s) ((`runStateT` s) . h)) + +instance (Monoid w, MonadCatch e m m') => MonadCatch e (RWST r w s m) (RWST r w s m') where catch (RWST m) h = RWST (\r s -> Catch.catch (m r s) ((\m -> runRWST m r s) . h)) diff --git a/Control/Monad/Exception/Throws.hs b/Control/Monad/Exception/Throws.hs --- a/Control/Monad/Exception/Throws.hs +++ b/Control/Monad/Exception/Throws.hs @@ -1,18 +1,14 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances, FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - {-| Defines the @Throws@ binary relationship between types. -} module Control.Monad.Exception.Throws ( Throws, Caught, - CheckedException(..), - UncaughtException, - NoExceptions, ParanoidMode) where + CheckedException(..) + ) where #if __GLASGOW_HASKELL__ < 610 import Control.Exception.Extensible (Exception(..), SomeException) @@ -25,30 +21,29 @@ data Caught e l --- Closing a type class with an unexported constraint --- @Private@ is unexported -class Private l -instance Private (Caught e l) - {-| @Throws@ is a type level binary relationship used to model a list of exceptions. - Usually there is no need for the user - to add further instances to @Throws@ except - to encode subtyping. - As there is no way to automatically infer - the subcases of an exception, they have to be encoded - manually mirroring the hierarchy defined in the defined - 'Exception' instances. + There are two cases in which the user may want + to add further instances to @Throws@. - For example, - the following instance encodes that @MyFileNotFoundException@ is - a subexception of @MyIOException@ : + 1. To encode subtyping. + 2. To declare an exception as unexplicit (a programming error). + + [/Subtyping/] + As there is no way to automatically infer + the subcases of an exception, they have to be encoded + manually mirroring the hierarchy defined in the defined + 'Exception' instances. + For example, + the following instance encodes that @MyFileNotFoundException@ is + a subexception of @MyIOException@ : + > instance Throws MyFileNotFoundException (Caught MyIOException l) - 'Throws' is not a transitive relation and every ancestor relation - must be explicitly encoded. + 'Throws' is not a transitive relation and every ancestor relation + must be explicitly encoded. > -- TopException > -- | @@ -58,12 +53,17 @@ > instance Throws ChildException (Caught TopException l) -- | > -- ChildException -'SomeException' is automatically - an ancestor of every other exception type. + 'SomeException' is automatically + an ancestor of every other exception type. + [/Programming Errors/] + In order to declare an exception @E@ as a programming error, which should + not be explicit nor checked, use a 'Throws' instance as follows: + +> instance Throws e l -} -class (Private l, Exception e) => Throws e l +class Exception e => Throws e l instance Throws e l => Throws e (Caught e' l) instance Exception e => Throws e (Caught e l) @@ -73,33 +73,6 @@ -- Capturing SomeException captures every possible exception instance Exception e => Throws e (Caught SomeException l) instance Throws SomeException (Caught SomeException l) -- Disambiguation instance - --- | Uncaught Exceptions model unchecked exceptions (a la RuntimeException in Java) --- --- In order to declare an unchecked exception @E@, --- all that is needed is to make @e@ an instance of @UncaughtException@ --- --- > instance UncaughtException E --- --- Note that declaring an exception E as unchecked does not automatically --- turn its children as unchecked too. This is a shortcoming of the current encoding. -{- --- If that is what you want, then --- declare E as unchecked using an instance of @Throws@: --- --- > instance Throws E l --- --- The shortcoming of this route is that runEMTParanoid won't be able to --- control exceptions declared unchecked this way. --} -class Exception e => UncaughtException e -instance UncaughtException e => Throws e NoExceptions - -data NoExceptions -instance Private NoExceptions - -data ParanoidMode -instance Private ParanoidMode -- Labelled SomeException -- ------------------------ diff --git a/control-monad-exception.cabal b/control-monad-exception.cabal --- a/control-monad-exception.cabal +++ b/control-monad-exception.cabal @@ -1,6 +1,6 @@ name: control-monad-exception -version: 0.5 -Cabal-Version: >= 1.2.3 +version: 0.6 +Cabal-Version: >= 1.6 build-type: Simple license: PublicDomain author: Pepe Iborra @@ -40,10 +40,12 @@ . In addition to explicitly typed exceptions his package provides: . - * Support for explicitly documented, unchecked exceptions (with 'tryEM'). + * Support for explicitly documented, unchecked exceptions (via 'Control.Monad.Exception.tryEMT'). . - * Support for selective unchecked exceptions (with 'UncaughtException'). + * Support for selective unchecked exceptions (via 'Control.Monad.Exception.UncaughtException'). . + * Support for selective unexplicit exceptions. + . * Support for exception call traces via 'Control.Monad.Loc.MonadLoc'. /Example:/ . > @@ -65,14 +67,16 @@ synopsis: Explicitly typed, checked exceptions with stack traces category: Control, Monads stability: experimental -tested-with: GHC ==6.8.2 -tested-with: GHC ==6.10.2 tested-with: GHC ==6.10.3 -Flag transformers - description: Use transformers and monads-fd instead of mtl +Flag mtl + description: Provide mtl instances default: True +Flag monadsfd + description: Provide monads-fd instances + default: True + Flag extensibleExceptions description: Use extensible-exception package default: False @@ -89,14 +93,16 @@ build-depends: base >= 4 && < 5 - if flag(transformers) - cpp-options: -DTRANSFORMERS - build-depends: - transformers >= 0.0.1 && <0.2, - monads-fd >= 0.0 && <0.1 - else + if flag(mtl) + cpp-options: -DMTL build-depends: mtl + exposed-modules : Control.Monad.Exception.Mtl + if flag(monadsfd) + cpp-options: -DMONADSFD + build-depends: transformers, monads-fd + exposed-modules : Control.Monad.Exception.MonadsFD + extensions: MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, @@ -105,7 +111,14 @@ UndecidableInstances exposed-modules: + Control.Monad.Exception + Control.Monad.Exception.Base Control.Monad.Exception.Catch Control.Monad.Exception.Throws - Control.Monad.Exception ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans + + + +source-repository head + type: git + location: git://github.com/pepeiborra/control-monad-exception.git