Control/Monad/Trans/Error.hs

    {-# LANGUAGE CPP #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Monad.Trans.Error
    -- Copyright   :  (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001,
    --                (c) Jeff Newbern 2003-2006,
    --                (c) Andriy Palamarchuk 2006
    -- License     :  BSD-style (see the file LICENSE)
    --
    -- Maintainer  :  ross@soi.city.ac.uk
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- This monad transformer adds the ability to fail or throw exceptions
    -- to a monad.
    --
    -- A sequence of actions succeeds, producing a value, only if all the
    -- actions in the sequence are successful.  If one fails with an error,
    -- the rest of the sequence is skipped and the composite action fails
    -- with that error.
    --
    -- If the value of the error is not required, the variant in
    -- "Control.Monad.Trans.Maybe" may be used instead.
    -----------------------------------------------------------------------------

    module Control.Monad.Trans.Error (
        -- * The ErrorT monad transformer
        Error(..),
        ErrorList(..),
        ErrorT(..),
        mapErrorT,
        -- * Error operations
        throwError,
        catchError,
        -- * Lifting other operations
        liftCallCC,
        liftListen,
        liftPass,
        -- * Examples
        -- $examples
      ) 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))
    -- exported by System.IO.Error from base-4.4
    catchIOError :: IO a -> (IOError -> IO a) -> IO a
    catchIOError = catch
    #endif

    -- | An exception to be thrown.
    --
    -- Minimal complete definition: 'noMsg' or 'strMsg'.
    class Error a where
        -- | Creates an exception without a message.
        -- The default implementation is @'strMsg' \"\"@.
        noMsg  :: a
        -- | Creates an exception with a message.
        -- The default implementation of @'strMsg' s@ is 'noMsg'.
        strMsg :: String -> a

        noMsg    = strMsg ""
        strMsg _ = noMsg

    instance Error IOException where
        strMsg = userError

    -- | A string can be thrown as an error.
    instance ErrorList a => Error [a] where
        strMsg = listMsg

    -- | Workaround so that we can have a Haskell 98 instance @'Error' 'String'@.
    class ErrorList a where
        listMsg :: String -> [a]

    instance ErrorList Char where
        listMsg = id

    -- ---------------------------------------------------------------------------
    -- Our parameterizable error monad

    #if !(MIN_VERSION_base(4,3,0))

    -- These instances are in base-4.3

    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

    -- | The error monad transformer. It can be used to add error handling
    -- to other monads.
    --
    -- The @ErrorT@ Monad structure is parameterized over two things:
    --
    -- * e - The error type.
    --
    -- * m - The inner monad.
    --
    -- The 'return' function yields a successful computation, while @>>=@
    -- sequences two subcomputations, failing on the first error.
    newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }

    -- | Map the unwrapped computation using the given function.
    --
    -- * @'runErrorT' ('mapErrorT' f m) = f ('runErrorT' m)@
    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

    -- | Signal an error value @e@.
    --
    -- * @'runErrorT' ('throwError' e) = 'return' ('Left' e)@
    --
    -- * @'throwError' e >>= m = 'throwError' e@
    throwError :: (Monad m, Error e) => e -> ErrorT e m a
    throwError l = ErrorT $ return (Left l)

    -- | Handle an error.
    --
    -- * @'catchError' h ('lift' m) = 'lift' m@
    --
    -- * @'catchError' h ('throwError' e) = h e@
    catchError :: (Monad m, Error e) =>
        ErrorT e m a                -- ^ the inner computation
        -> (e -> ErrorT e m a)      -- ^ a handler for errors in the inner
                                    -- computation
        -> 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)

    -- | Lift a @callCC@ operation to the new monad.
    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)))

    -- | Lift a @listen@ operation to the new monad.
    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

    -- | Lift a @pass@ operation to the new monad.
    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)

    {- $examples

    Wrapping an IO action that can throw an error @e@:

    > type ErrorWithIO e a = ErrorT e IO a
    > ==> ErrorT (IO (Either e a))

    An IO monad wrapped in @StateT@ inside of @ErrorT@:

    > type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a
    > ==> ErrorT (StateT s IO (Either e a))
    > ==> ErrorT (StateT (s -> IO (Either e a,s)))

    -}