module Control.Monad.Exception.Base where
import Control.Applicative
import Control.Monad.Exception.Catch
import Control.Monad.Loc
import Control.Monad.Trans.Class
import Control.Failure
import Control.Monad.Fix
import Data.Typeable
import Prelude hiding (catch)
type CallTrace = [String]
newtype EMT l m a = EMT {unEMT :: m (Either (CallTrace, CheckedException l) a)}
tryEMT :: Monad m => EMT AnyException m a -> m (Either SomeException a)
tryEMT (EMT m) = mapLeft (checkedException.snd) `liftM` m
tryEMTWithLoc :: Monad m => EMT AnyException m a -> m (Either (CallTrace, SomeException) a)
tryEMTWithLoc = liftM (mapLeft (\(l,ce) -> (l, checkedException ce))) . unEMT
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 AnyException
data NoExceptions
data ParanoidMode
instance Exception e => Throws e AnyException
runEMT :: Monad m => EMT NoExceptions m a -> m a
runEMT = runEMT_gen
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) => Failure e (EMT l m) where
failure = throw
instance (Exception e, Throws e l, Failure e m, 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 MonadTrans (EMT l) where
lift = EMT . liftM Right
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"
throw :: (Exception e, Throws e l, Monad m) => e -> EMT l m a
throw = EMT . return . (\e -> Left ([],e)) . CheckedException . toException
rethrow :: (Throws e l, Monad m) => CallTrace -> e -> EMT l m a
rethrow callt = EMT . return . (\e -> Left (callt,e)) . CheckedException . toException
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)
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')
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}
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
-> (a -> EMT l m b)
-> (a -> EMT l m c)
-> EMT l m c
bracket acquire release run = do { k <- acquire; run k `finally` (release k) }
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 = unlines ( show e
: [ " in " ++ show loc | loc <- reverse trace])
class Exception e => UncaughtException e
instance UncaughtException e => Throws e NoExceptions
instance UncaughtException SomeException
type EM l = EMT l Identity
tryEM :: EM AnyException a -> Either SomeException a
tryEM = runIdentity . tryEMT
tryEMWithLoc :: EM AnyException a -> Either (CallTrace, SomeException) a
tryEMWithLoc = runIdentity . tryEMTWithLoc
runEM :: EM NoExceptions a -> a
runEM = runIdentity . runEMT
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
instance (Throws MonadZeroException l) => MonadPlus (EM l) where
mzero = throw MonadZeroException
mplus = mplusDefault
data FailException = FailException String deriving (Show, Typeable)
instance Exception FailException
data MonadZeroException = MonadZeroException deriving (Show, Typeable)
instance Exception MonadZeroException
mplusDefault :: Monad m => EMT l m a -> EMT l m a -> EMT l m a
mplusDefault emt1 emt2 = EMT$ do
v1 <- unEMT emt1
case v1 of
Left (_,CheckedException e) | Just MonadZeroException <- fromException e -> unEMT emt2
_ -> return v1
mapLeft :: (a -> b) -> Either a r -> Either b r
mapLeft f (Left x) = Left (f x)
mapLeft _ (Right x) = Right x