979ae35b4c67bda40d7db522ac6025ad072b18d8
[packages/base.git] / 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.1 2001/06/28 14:15:02 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