Revision 565821d1
b/src/Ganeti/BasicTypes.hs | ||
---|---|---|
26 | 26 |
, genericResult |
27 | 27 |
, Result |
28 | 28 |
, ResultT(..) |
29 |
, mkResultT |
|
30 |
, withError |
|
31 |
, withErrorT |
|
29 | 32 |
, resultT |
33 |
, toErrorStr |
|
30 | 34 |
, Error(..) -- re-export from Control.Monad.Error |
31 | 35 |
, isOk |
32 | 36 |
, isBad |
... | ... | |
34 | 38 |
, justBad |
35 | 39 |
, eitherToResult |
36 | 40 |
, annotateResult |
41 |
, annotateError |
|
42 |
, failError |
|
43 |
, catchErrorT |
|
44 |
, handleErrorT |
|
37 | 45 |
, iterateOk |
38 | 46 |
, select |
39 | 47 |
, LookupResult(..) |
... | ... | |
70 | 78 |
genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c |
71 | 79 |
genericResult f _ (Bad a) = f a |
72 | 80 |
genericResult _ g (Ok b) = g b |
81 |
{-# INLINE genericResult #-} |
|
73 | 82 |
|
74 | 83 |
-- | Type alias for a string Result. |
75 | 84 |
type Result = GenericResult String |
... | ... | |
95 | 104 |
|
96 | 105 |
instance (Error a) => MonadError a (GenericResult a) where |
97 | 106 |
throwError = Bad |
107 |
{-# INLINE throwError #-} |
|
98 | 108 |
catchError x h = genericResult h (const x) x |
109 |
{-# INLINE catchError #-} |
|
99 | 110 |
|
100 | 111 |
instance Applicative (GenericResult a) where |
101 | 112 |
pure = Ok |
... | ... | |
109 | 120 |
|
110 | 121 |
-- | This is a monad transformation for Result. It's implementation is |
111 | 122 |
-- based on the implementations of MaybeT and ErrorT. |
123 |
-- |
|
124 |
-- 'ResultT' is very similar to @ErrorT@, but with one subtle difference: |
|
125 |
-- If 'mplus' combines two failing operations, errors of both of them |
|
126 |
-- are combined. |
|
112 | 127 |
newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)} |
113 | 128 |
|
114 | 129 |
-- | Eliminates a 'ResultT' value given appropriate continuations |
... | ... | |
137 | 152 |
|
138 | 153 |
instance (Monad m, Error a) => MonadError a (ResultT a m) where |
139 | 154 |
throwError = resultT . Bad |
140 |
catchError x h = elimResultT h return x
|
|
155 |
catchError = catchErrorT
|
|
141 | 156 |
|
142 | 157 |
instance MonadTrans (ResultT a) where |
143 | 158 |
lift = ResultT . liftM Ok |
... | ... | |
156 | 171 |
empty = mzero |
157 | 172 |
(<|>) = mplus |
158 | 173 |
|
174 |
-- | Changes the error message of a result value, if present. |
|
175 |
-- Note that since 'GenericResult' is also a 'MonadError', this function |
|
176 |
-- is a generalization of |
|
177 |
-- @(Error e') => (e' -> e) -> GenericResult e' a -> GenericResult e a@ |
|
178 |
withError :: (MonadError e m) => (e' -> e) -> GenericResult e' a -> m a |
|
179 |
withError f = genericResult (throwError . f) return |
|
180 |
|
|
181 |
-- | Changes the error message of a @ResultT@ value, if present. |
|
182 |
withErrorT :: (Monad m, Error e) |
|
183 |
=> (e' -> e) -> ResultT e' m a -> ResultT e m a |
|
184 |
withErrorT f = ResultT . liftM (withError f) . runResultT |
|
185 |
|
|
159 | 186 |
-- | Lift a `Result` value to a `ResultT`. |
160 | 187 |
resultT :: Monad m => GenericResult a b -> ResultT a m b |
161 | 188 |
resultT = ResultT . return |
162 | 189 |
|
190 |
-- | An alias for @withError strMsg@, which is often used to lift a pure error |
|
191 |
-- to a monad stack. See also 'annotateResult'. |
|
192 |
toErrorStr :: (MonadError e m, Error e) => Result a -> m a |
|
193 |
toErrorStr = withError strMsg |
|
194 |
|
|
195 |
-- | Converts a monadic result with a 'String' message into |
|
196 |
-- a 'ResultT' with an arbitrary 'Error'. |
|
197 |
-- |
|
198 |
-- Expects that the given action has already taken care of any possible |
|
199 |
-- errors. In particular, if applied on @IO (Result a)@, any exceptions |
|
200 |
-- should be handled by the given action. |
|
201 |
-- |
|
202 |
-- See also 'toErrorStr'. |
|
203 |
mkResultT :: (Monad m, Error e) => m (Result a) -> ResultT e m a |
|
204 |
mkResultT = ResultT . liftM toErrorStr |
|
205 |
|
|
163 | 206 |
-- | Simple checker for whether a 'GenericResult' is OK. |
164 | 207 |
isOk :: GenericResult a b -> Bool |
165 | 208 |
isOk (Ok _) = True |
... | ... | |
182 | 225 |
eitherToResult (Left s) = Bad s |
183 | 226 |
eitherToResult (Right v) = Ok v |
184 | 227 |
|
185 |
-- | Annotate a Result with an ownership information. |
|
228 |
--- | Annotate a Result with an ownership information.
|
|
186 | 229 |
annotateResult :: String -> Result a -> Result a |
187 | 230 |
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s |
188 | 231 |
annotateResult _ v = v |
189 | 232 |
|
233 |
-- | Annotate an error with an ownership information inside a 'MonadError'. |
|
234 |
-- See also 'annotateResult'. |
|
235 |
annotateError :: (MonadError e m, Error e, Monoid e) => String -> m a -> m a |
|
236 |
annotateError owner = |
|
237 |
flip catchError (throwError . mappend (strMsg $ owner ++ ": ")) |
|
238 |
{-# INLINE annotateError #-} |
|
239 |
|
|
240 |
-- | Throws a 'String' message as an error in a 'MonadError'. |
|
241 |
-- This is a generalization of 'Bad'. |
|
242 |
-- It's similar to 'fail', but works within a 'MonadError', avoiding the |
|
243 |
-- unsafe nature of 'fail'. |
|
244 |
failError :: (MonadError e m, Error e) => String -> m a |
|
245 |
failError = throwError . strMsg |
|
246 |
|
|
247 |
-- | A synonym for @flip@ 'catchErrorT'. |
|
248 |
handleErrorT :: (Monad m, Error e) |
|
249 |
=> (e' -> ResultT e m a) -> ResultT e' m a -> ResultT e m a |
|
250 |
handleErrorT handler = elimResultT handler return |
|
251 |
{-# INLINE handleErrorT #-} |
|
252 |
|
|
253 |
-- | Catches an error in a @ResultT@ value. This is similar to 'catchError', |
|
254 |
-- but in addition allows to change the error type. |
|
255 |
catchErrorT :: (Monad m, Error e) |
|
256 |
=> ResultT e' m a -> (e' -> ResultT e m a) -> ResultT e m a |
|
257 |
catchErrorT = flip handleErrorT |
|
258 |
{-# INLINE catchErrorT #-} |
|
259 |
|
|
190 | 260 |
-- | Iterate while Ok. |
191 | 261 |
iterateOk :: (a -> GenericResult b a) -> a -> [a] |
192 | 262 |
iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a) |
Also available in: Unified diff