module Control.Monad.Exception.Synchronous where
import Control.Applicative (Applicative(pure, (<*>)))
import Control.Monad (liftM, )
import Control.Monad.Fix (MonadFix, mfix, )
import Control.Monad.Trans (MonadTrans, lift, )
import Control.Monad.Error (ErrorT(ErrorT, runErrorT))
import Prelude hiding (catch, )
data Exceptional e a =
Success a
| Exception e
deriving (Show, Eq)
fromMaybe :: e -> Maybe a -> Exceptional e a
fromMaybe e = maybe (Exception e) Success
fromEither :: Either e a -> Exceptional e a
fromEither = either Exception Success
toEither :: Exceptional e a -> Either e a
toEither x =
case x of
Success a -> Right a
Exception e -> Left e
force :: Exceptional e a -> Exceptional e a
force ~(Success a) = Success a
mapException :: (e0 -> e1) -> Exceptional e0 a -> Exceptional e1 a
mapException f x =
case x of
Success a -> Success a
Exception e -> Exception (f e)
mapExceptional :: (e0 -> e1) -> (a -> b) -> Exceptional e0 a -> Exceptional e1 b
mapExceptional f g x =
case x of
Success a -> Success (g a)
Exception e -> Exception (f e)
throw :: e -> Exceptional e a
throw = Exception
catch :: Exceptional e0 a -> (e0 -> Exceptional e1 a) -> Exceptional e1 a
catch x handler =
case x of
Success a -> Success a
Exception e -> handler e
resolve :: (e -> a) -> Exceptional e a -> a
resolve handler x =
case x of
Success a -> a
Exception e -> handler e
instance Functor (Exceptional e) where
fmap f x =
case x of
Success a -> Success (f a)
Exception e -> Exception e
instance Applicative (Exceptional e) where
pure = Success
f <*> x =
case f of
Exception e -> Exception e
Success g ->
case x of
Success a -> Success (g a)
Exception e -> Exception e
instance Monad (Exceptional e) where
return = Success
fail _msg = Exception (error "Exception.Synchronous: Monad.fail method is not supported")
x >>= f =
case x of
Exception e -> Exception e
Success y -> f y
instance MonadFix (Exceptional e) where
mfix f =
let unSuccess ~(Success x) = x
a = f (unSuccess a)
in a
newtype ExceptionalT e m a =
ExceptionalT {runExceptionalT :: m (Exceptional e a)}
fromErrorT :: Monad m => ErrorT e m a -> ExceptionalT e m a
fromErrorT = ExceptionalT . liftM fromEither . runErrorT
toErrorT :: Monad m => ExceptionalT e m a -> ErrorT e m a
toErrorT = ErrorT . liftM toEither . runExceptionalT
forceT :: Monad m => ExceptionalT e m a -> ExceptionalT e m a
forceT =
ExceptionalT . liftM force . runExceptionalT
mapExceptionT :: (Monad m) =>
(e0 -> e1) ->
ExceptionalT e0 m a ->
ExceptionalT e1 m a
mapExceptionT f =
ExceptionalT . liftM (mapException f) . runExceptionalT
mapExceptionalT ::
(m (Exceptional e0 a) -> n (Exceptional e1 b)) ->
ExceptionalT e0 m a -> ExceptionalT e1 n b
mapExceptionalT f =
ExceptionalT . f . runExceptionalT
throwT :: (Monad m) =>
e -> ExceptionalT e m a
throwT = ExceptionalT . return . throw
catchT :: (Monad m) =>
ExceptionalT e0 m a ->
(e0 -> ExceptionalT e1 m a) ->
ExceptionalT e1 m a
catchT action handler =
ExceptionalT $
runExceptionalT action >>= \x ->
case x of
Success a -> return $ Success a
Exception e -> runExceptionalT $ handler e
bracketT :: (Monad m) =>
ExceptionalT e m h ->
(h -> ExceptionalT e m ()) ->
(h -> ExceptionalT e m a) ->
ExceptionalT e m a
bracketT open close action =
open >>= \h ->
ExceptionalT $
do a <- runExceptionalT (action h)
c <- runExceptionalT (close h)
return (a >>= \r -> c >> return r)
resolveT :: (Monad m) =>
(e -> m a) -> ExceptionalT e m a -> m a
resolveT handler x =
do r <- runExceptionalT x
resolve handler (fmap return r)
tryT :: (Monad m) =>
ExceptionalT e m a -> m (Exceptional e a)
tryT = runExceptionalT
manyT :: (Monad m) =>
(e0 -> Maybe e1) ->
(a -> b -> b) ->
b ->
ExceptionalT e0 m a ->
ExceptionalT e1 m b
manyT handler cons empty action =
let recurse =
do r <- lift $ tryT action
case r of
Exception e -> maybe (return empty) throwT (handler e)
Success x -> liftM (cons x) recurse
in recurse
instance Functor m => Functor (ExceptionalT e m) where
fmap f (ExceptionalT x) =
ExceptionalT (fmap (fmap f) x)
instance Applicative m => Applicative (ExceptionalT e m) where
pure = ExceptionalT . pure . pure
ExceptionalT f <*> ExceptionalT x =
ExceptionalT (fmap (<*>) f <*> x)
instance Monad m => Monad (ExceptionalT e m) where
return = ExceptionalT . return . return
x0 >>= f =
ExceptionalT $
runExceptionalT x0 >>= \x1 ->
case x1 of
Exception e -> return (Exception e)
Success x -> runExceptionalT $ f x
instance (MonadFix m) => MonadFix (ExceptionalT e m) where
mfix f = ExceptionalT $ mfix $ \(Success r) -> runExceptionalT $ f r
instance MonadTrans (ExceptionalT e) where
lift m = ExceptionalT $ liftM Success m