#if __GLASGOW_HASKELL__ >= 702
#endif
#if __GLASGOW_HASKELL__ >= 710
#endif
#if !(MIN_VERSION_base(4,9,0))
#endif
module Control.Monad.Trans.Error
(
Error(..),
ErrorList(..),
ErrorT(..),
mapErrorT,
throwError,
catchError,
liftCallCC,
liftListen,
liftPass,
) where
import Control.Monad.IO.Class
import Control.Monad.Signatures
import Control.Monad.Trans.Class
import Data.Functor.Classes
#if MIN_VERSION_base(4,12,0)
import Data.Functor.Contravariant
#endif
import Control.Applicative
import Control.Exception (IOException)
import Control.Monad
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
import Control.Monad.Fix
#if !(MIN_VERSION_base(4,6,0))
import Control.Monad.Instances ()
#endif
import Data.Foldable (Foldable(foldMap))
import Data.Monoid (mempty)
import Data.Traversable (Traversable(traverse))
import System.IO.Error
#if !(MIN_VERSION_base(4,9,0))
instance MonadPlus IO where
mzero = ioError (userError "mzero")
m `mplus` n = m `catchIOError` \ _ -> n
instance Alternative IO where
empty = mzero
(<|>) = mplus
# if !(MIN_VERSION_base(4,4,0))
catchIOError :: IO a -> (IOError -> IO a) -> IO a
catchIOError = catch
# endif
#endif
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
#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 */
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
newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }
instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where
liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y
instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where
liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y
instance (Read e, Read1 m) => Read1 (ErrorT e m) where
liftReadsPrec rp rl = readsData $
readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT
where
rp' = liftReadsPrec rp rl
rl' = liftReadList rp rl
instance (Show e, Show1 m) => Show1 (ErrorT e m) where
liftShowsPrec sp sl d (ErrorT m) =
showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m
where
sp' = liftShowsPrec sp sl
sl' = liftShowList sp sl
instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1
instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1
instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where
readsPrec = readsPrec1
instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where
showsPrec = showsPrec1
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
#if !(MIN_VERSION_base(4,8,0))
return a = ErrorT $ return (Right a)
#endif
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))
#if MIN_VERSION_base(4,9,0)
instance (Monad m, Error e) => Fail.MonadFail (ErrorT e m) where
fail msg = ErrorT $ return (Left (strMsg msg))
#endif
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 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
#if MIN_VERSION_base(4,12,0)
instance Contravariant m => Contravariant (ErrorT e m) where
contramap f = ErrorT . contramap (fmap f) . runErrorT
#endif
throwError :: (Monad m) => e -> ErrorT e m a
throwError l = ErrorT $ return (Left l)
catchError :: (Monad m) =>
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 :: CallCC m (Either e a) (Either e b) -> CallCC (ErrorT e m) a b
liftCallCC callCC f = ErrorT $
callCC $ \ c ->
runErrorT (f (\ a -> ErrorT $ c (Right a)))
liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ErrorT e m) a
liftListen listen = mapErrorT $ \ m -> do
(a, w) <- listen m
return $! fmap (\ r -> (r, w)) a
liftPass :: (Monad m) => Pass w m (Either e a) -> Pass 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)