{-# LANGUAGE CPP #-}
module Control.Monad.Trans.Error (
Error(..),
ErrorList(..),
ErrorT(..),
mapErrorT,
throwError,
catchError,
liftCallCC,
liftListen,
liftPass,
) where
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Applicative
import Control.Exception (IOException)
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Instances ()
import Data.Foldable (Foldable(foldMap))
import Data.Monoid (mempty)
import Data.Traversable (Traversable(traverse))
import System.IO.Error
instance MonadPlus IO where
mzero = ioError (userError "mzero")
m `mplus` n = m `catchIOError` \_ -> n
#if !(MIN_VERSION_base(4,4,0))
catchIOError :: IO a -> (IOError -> IO a) -> IO a
catchIOError = catch
#endif
class Error a where
noMsg :: a
strMsg :: String -> a
noMsg = strMsg ""
strMsg _ = noMsg
instance Error IOException where
strMsg = userError
instance ErrorList a => Error [a] where
strMsg = listMsg
class ErrorList a where
listMsg :: String -> [a]
instance ErrorList Char where
listMsg = id
#if !(MIN_VERSION_base(4,3,0))
instance Applicative (Either e) where
pure = Right
Left e <*> _ = Left e
Right f <*> r = fmap f r
instance Monad (Either e) where
return = Right
Left l >>= _ = Left l
Right r >>= k = k r
instance MonadFix (Either e) where
mfix f = let
a = f $ case a of
Right r -> r
_ -> error "empty mfix argument"
in a
#endif /* base to 4.2.0.x */
instance (Error e) => Alternative (Either e) where
empty = Left noMsg
Left _ <|> n = n
m <|> _ = m
instance (Error e) => MonadPlus (Either e) where
mzero = Left noMsg
Left _ `mplus` n = n
m `mplus` _ = m
newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }
mapErrorT :: (m (Either e a) -> n (Either e' b))
-> ErrorT e m a
-> ErrorT e' n b
mapErrorT f m = ErrorT $ f (runErrorT m)
instance (Functor m) => Functor (ErrorT e m) where
fmap f = ErrorT . fmap (fmap f) . runErrorT
instance (Foldable f) => Foldable (ErrorT e f) where
foldMap f (ErrorT a) = foldMap (either (const mempty) f) a
instance (Traversable f) => Traversable (ErrorT e f) where
traverse f (ErrorT a) =
ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a
instance (Functor m, Monad m) => Applicative (ErrorT e m) where
pure a = ErrorT $ return (Right a)
f <*> v = ErrorT $ do
mf <- runErrorT f
case mf of
Left e -> return (Left e)
Right k -> do
mv <- runErrorT v
case mv of
Left e -> return (Left e)
Right x -> return (Right (k x))
instance (Functor m, Monad m, Error e) => Alternative (ErrorT e m) where
empty = mzero
(<|>) = mplus
instance (Monad m, Error e) => Monad (ErrorT e m) where
return a = ErrorT $ return (Right a)
m >>= k = ErrorT $ do
a <- runErrorT m
case a of
Left l -> return (Left l)
Right r -> runErrorT (k r)
fail msg = ErrorT $ return (Left (strMsg msg))
instance (Monad m, Error e) => MonadPlus (ErrorT e m) where
mzero = ErrorT $ return (Left noMsg)
m `mplus` n = ErrorT $ do
a <- runErrorT m
case a of
Left _ -> runErrorT n
Right r -> return (Right r)
instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where
mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of
Right r -> r
_ -> error "empty mfix argument"
instance (Error e) => MonadTrans (ErrorT e) where
lift m = ErrorT $ do
a <- m
return (Right a)
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
liftIO = lift . liftIO
throwError :: (Monad m, Error e) => e -> ErrorT e m a
throwError l = ErrorT $ return (Left l)
catchError :: (Monad m, Error e) =>
ErrorT e m a
-> (e -> ErrorT e m a)
-> ErrorT e m a
m `catchError` h = ErrorT $ do
a <- runErrorT m
case a of
Left l -> runErrorT (h l)
Right r -> return (Right r)
liftCallCC :: (((Either e a -> m (Either e b)) -> m (Either e a)) ->
m (Either e a)) -> ((a -> ErrorT e m b) -> ErrorT e m a) -> ErrorT e m a
liftCallCC callCC f = ErrorT $
callCC $ \c ->
runErrorT (f (\a -> ErrorT $ c (Right a)))
liftListen :: Monad m =>
(m (Either e a) -> m (Either e a,w)) -> ErrorT e m a -> ErrorT e m (a,w)
liftListen listen = mapErrorT $ \ m -> do
(a, w) <- listen m
return $! fmap (\ r -> (r, w)) a
liftPass :: Monad m => (m (Either e a,w -> w) -> m (Either e a)) ->
ErrorT e m (a,w -> w) -> ErrorT e m a
liftPass pass = mapErrorT $ \ m -> pass $ do
a <- m
return $! case a of
Left l -> (Left l, id)
Right (r, f) -> (Right r, f)