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