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