Control/Monad/Error.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Control.Monad.Error
   4 -- Copyright   :  (c) Michael Weber <michael.weber@post.rwth-aachen.de>, 2001
   5 -- License     :  BSD-style (see the file libraries/core/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable (reqruires multi-param type classes)
  10 --
  11 -- $Id: Error.hs,v 1.2 2002/04/24 16:31:38 simonmar Exp $
  12 --
  13 -- The Error monad.
  14 --
  15 -- Rendered by Michael Weber <michael.weber@post.rwth-aachen.de>,
  16 --      inspired by the Haskell Monad Template Library from
  17 --       \A[HREF="http://www.cse.ogi.edu/~andy"]{Andy Gill}}
  18 --
  19 -----------------------------------------------------------------------------
  20
  21 module Control.Monad.Error (
  22         Error(..),
  23         MonadError(..),
  24         ErrorT(..),
  25         runErrorT,
  26         mapErrorT,
  27         module Control.Monad,
  28         module Control.Monad.Fix,
  29         module Control.Monad.Trans,
  30   ) where
  31
  32 import Prelude
  33
  34 import Control.Monad
  35 import Control.Monad.Fix
  36 import Control.Monad.Trans
  37 import Control.Monad.Reader
  38 import Control.Monad.Writer
  39 import Control.Monad.State
  40 import Control.Monad.RWS
  41 import Control.Monad.Cont
  42
  43 import System.IO
  44
  45 -- ---------------------------------------------------------------------------
  46 -- class MonadError
  47 --
  48 --    throws an exception inside the monad and thus interrupts
  49 --    normal execution order, until an error handler is reached}
  50 --
  51 --    catches an exception inside the monad (that was previously
  52 --    thrown by throwError
  53
  54 class Error a where
  55         noMsg  :: a
  56         strMsg :: String -> a
  57
  58         noMsg    = strMsg ""
  59         strMsg _ = noMsg
  60
  61 instance Error [Char] where
  62         noMsg  = ""
  63         strMsg = id
  64
  65 instance Error IOError where
  66         strMsg = userError
  67
  68 class (Monad m) => MonadError e m | m -> e where
  69         throwError :: e -> m a
  70         catchError :: m a -> (e -> m a) -> m a
  71
  72 instance MonadPlus IO where
  73         mzero       = ioError (userError "mzero")
  74         m `mplus` n = m `catch` \_ -> n
  75
  76 instance MonadError IOError IO where
  77         throwError = ioError
  78         catchError = catch
  79
  80 -- ---------------------------------------------------------------------------
  81 -- Our parameterizable error monad
  82
  83 instance Functor (Either e) where
  84         fmap _ (Left  l) = Left  l
  85         fmap f (Right r) = Right (f r)
  86
  87 instance (Error e) => Monad (Either e) where
  88         return        = Right
  89         Left  l >>= _ = Left l
  90         Right r >>= k = k r
  91         fail msg      = Left (strMsg msg)
  92
  93 instance (Error e) => MonadPlus (Either e) where
  94         mzero            = Left noMsg
  95         Left _ `mplus` n = n
  96         m      `mplus` _ = m
  97
  98 instance (Error e) => MonadFix (Either e) where
  99         mfix f = let
 100                 a = f $ case a of
 101                         Right r -> r
 102                         _       -> error "empty mfix argument"
 103                 in a
 104
 105 instance (Error e) => MonadError e (Either e) where
 106         throwError             = Left
 107         Left  l `catchError` h = h l
 108         Right r `catchError` _ = Right r
 109
 110 -- ---------------------------------------------------------------------------
 111 -- Our parameterizable error monad, with an inner monad
 112
 113 newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }
 114
 115 -- The ErrorT Monad structure is parameterized over two things:
 116 --      * e - The error type.
 117 --      * m - The inner monad.
 118
 119 -- Here are some examples of use:
 120 --
 121 --   type ErrorWithIO e a = ErrorT e IO a
 122 --      ==> ErrorT (IO (Either e a))
 123 --
 124 --   type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a
 125 --      ==> ErrorT (StateT s IO (Either e a))
 126 --      ==> ErrorT (StateT (s -> IO (Either e a,s)))
 127 --
 128
 129 instance (Monad m) => Functor (ErrorT e m) where
 130         fmap f m = ErrorT $ do
 131                 a <- runErrorT m
 132                 case a of
 133                         Left  l -> return (Left  l)
 134                         Right r -> return (Right (f r))
 135
 136 instance (Monad m, Error e) => Monad (ErrorT e m) where
 137         return a = ErrorT $ return (Right a)
 138         m >>= k  = ErrorT $ do
 139                 a <- runErrorT m
 140                 case a of
 141                         Left  l -> return (Left l)
 142                         Right r -> runErrorT (k r)
 143         fail msg = ErrorT $ return (Left (strMsg msg))
 144
 145 instance (Monad m, Error e) => MonadPlus (ErrorT e m) where
 146         mzero       = ErrorT $ return (Left noMsg)
 147         m `mplus` n = ErrorT $ do
 148                 a <- runErrorT m
 149                 case a of
 150                         Left  _ -> runErrorT n
 151                         Right r -> return (Right r)
 152
 153 instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where
 154         mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of
 155                 Right r -> r
 156                 _       -> error "empty mfix argument"
 157
 158 instance (Monad m, Error e) => MonadError e (ErrorT e m) where
 159         throwError l     = ErrorT $ return (Left l)
 160         m `catchError` h = ErrorT $ do
 161                 a <- runErrorT m
 162                 case a of
 163                         Left  l -> runErrorT (h l)
 164                         Right r -> return (Right r)
 165
 166 instance (Error e) => MonadTrans (ErrorT e) where
 167         lift m = ErrorT $ do
 168                 a <- m
 169                 return (Right a)
 170
 171 instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
 172         liftIO = lift . liftIO
 173
 174 instance (Error e, MonadReader r m) => MonadReader r (ErrorT e m) where
 175         ask       = lift ask
 176         local f m = ErrorT $ local f (runErrorT m)
 177
 178 instance (Error e, MonadWriter w m) => MonadWriter w (ErrorT e m) where
 179         tell     = lift . tell
 180         listen m = ErrorT $ do
 181                 (a, w) <- listen (runErrorT m)
 182                 return $ case a of
 183                         Left  l -> Left  l
 184                         Right r -> Right (r, w)
 185         pass   m = ErrorT $ pass $ do
 186                 a <- runErrorT m
 187                 return $ case a of
 188                         Left  l      -> (Left  l, id)
 189                         Right (r, f) -> (Right r, f)
 190
 191 instance (Error e, MonadState s m) => MonadState s (ErrorT e m) where
 192         get = lift get
 193         put = lift . put
 194
 195 instance (Error e, MonadCont m) => MonadCont (ErrorT e m) where
 196         callCC f = ErrorT $
 197                 callCC $ \c ->
 198                 runErrorT (f (\a -> ErrorT $ c (Right a)))
 199
 200 mapErrorT :: (m (Either e a) -> n (Either e' b)) -> ErrorT e m a -> ErrorT e' n b
 201 mapErrorT f m = ErrorT $ f (runErrorT m)
 202
 203 -- ---------------------------------------------------------------------------
 204 -- MonadError instances for other monad transformers
 205
 206 instance (MonadError e m) => MonadError e (ReaderT r m) where
 207         throwError       = lift . throwError
 208         m `catchError` h = ReaderT $ \r -> runReaderT m r
 209                 `catchError` \e -> runReaderT (h e) r
 210
 211 instance (Monoid w, MonadError e m) => MonadError e (WriterT w m) where
 212         throwError       = lift . throwError
 213         m `catchError` h = WriterT $ runWriterT m
 214                 `catchError` \e -> runWriterT (h e)
 215
 216 instance (MonadError e m) => MonadError e (StateT s m) where
 217         throwError       = lift . throwError
 218         m `catchError` h = StateT $ \s -> runStateT m s
 219                 `catchError` \e -> runStateT (h e) s
 220
 221 instance (Monoid w, MonadError e m) => MonadError e (RWST r w s m) where
 222         throwError       = lift . throwError
 223         m `catchError` h = RWST $ \r s -> runRWST m r s
 224                 `catchError` \e -> runRWST (h e) r s