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