module Control.Monad.Exception.Base where
import qualified Control.Exception as CE
import Control.Applicative
import Control.Monad.Exception.Catch
import Control.Monad.Loc
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Control.Failure
import Control.Monad.Fix
import Data.Typeable
import Data.Functor.Identity
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
#if !MIN_VERSION_failure(0,2,0)
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)
#endif
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
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
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))