MonadError.hs

{-
  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
  
  This program is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  any later version.
  
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
  
  You should have received a copy of the GNU General Public License
  along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

{-# LANGUAGE TypeFamilies #-}
module DBus.Util.MonadError where
import Control.Monad.Trans.Class
import Control.Monad.State

newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }

instance Functor m => Functor (ErrorT e m) where
        fmap f = ErrorT . fmap (fmap f) . runErrorT

instance Monad m => Monad (ErrorT e m) where
        return = ErrorT . return . Right
        (>>=) m k = ErrorT $ do
                x <- runErrorT m
                case x of
                        Left l -> return $ Left l
                        Right r -> runErrorT $ k r

instance MonadTrans (ErrorT e) where
        lift = ErrorT . liftM Right

class Monad m => MonadError m where
        type ErrorType m
        throwError :: ErrorType m -> m a
        catchError :: m a -> (ErrorType m -> m a) -> m a

instance Monad m => MonadError (ErrorT e m) where
        type ErrorType (ErrorT e m) = e
        throwError = ErrorT . return . Left
        catchError m h = ErrorT $ do
                x <- runErrorT m
                case x of
                        Left l -> runErrorT $ h l
                        Right r -> return $ Right r

instance MonadState m => MonadState (ErrorT e m) where
        type StateType (ErrorT e m) = StateType m
        get = lift get
        put = lift . put