Merge branch 'stable-2.15' into stable-2.16
[ganeti-github.git] / src / Ganeti / BasicTypes.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE TypeFamilies #-}
5 {-# LANGUAGE DeriveFunctor #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 {-# LANGUAGE CPP #-}
8
9 {-
10
11 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
12 All rights reserved.
13
14 Redistribution and use in source and binary forms, with or without
15 modification, are permitted provided that the following conditions are
16 met:
17
18 1. Redistributions of source code must retain the above copyright notice,
19 this list of conditions and the following disclaimer.
20
21 2. Redistributions in binary form must reproduce the above copyright
22 notice, this list of conditions and the following disclaimer in the
23 documentation and/or other materials provided with the distribution.
24
25 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
26 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
27 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
29 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
32 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
33 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
34 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
35 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36
37 -}
38
39 module Ganeti.BasicTypes
40 ( GenericResult(..)
41 , genericResult
42 , Result
43 , ResultT(..)
44 , mkResultT
45 , withError
46 , withErrorT
47 , toError
48 , toErrorBase
49 , toErrorStr
50 , tryError
51 , Error(..) -- re-export from Control.Monad.Error
52 , MonadIO(..) -- re-export from Control.Monad.IO.Class
53 , isOk
54 , isBad
55 , justOk
56 , justBad
57 , eitherToResult
58 , isLeft
59 , isRight
60 , annotateResult
61 , annotateError
62 , failError
63 , catchErrorT
64 , handleErrorT
65 , orElse
66 , iterateOk
67 , select
68 , runListHead
69 , LookupResult(..)
70 , MatchPriority(..)
71 , lookupName
72 , goodLookupResult
73 , goodMatchPriority
74 , prefixMatch
75 , compareNameComponent
76 , ListSet(..)
77 , emptyListSet
78 ) where
79
80 import Control.Applicative
81 import Control.Exception (try)
82 import Control.Monad
83 import Control.Monad.Base
84 import Control.Monad.Error.Class
85 import Control.Monad.Trans
86 import Control.Monad.Trans.Control
87 import Data.Function
88 import Data.List
89 import Data.Maybe
90 import Data.Monoid
91 import Data.Set (Set)
92 import qualified Data.Set as Set (empty)
93 import Text.JSON (JSON)
94 import qualified Text.JSON as JSON (readJSON, showJSON)
95
96 -- Remove after we require >= 1.8.58
97 -- See: https://github.com/ndmitchell/hlint/issues/24
98 {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}
99
100 -- | Generic monad for our error handling mechanisms.
101 data GenericResult a b
102 = Bad a
103 | Ok b
104 deriving (Show, Eq)
105
106 -- | Sum type structure of GenericResult.
107 genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c
108 genericResult f _ (Bad a) = f a
109 genericResult _ g (Ok b) = g b
110 {-# INLINE genericResult #-}
111
112 -- | Type alias for a string Result.
113 type Result = GenericResult String
114
115 -- | 'Monad' instance for 'GenericResult'.
116 instance (Error a) => Monad (GenericResult a) where
117 (>>=) (Bad x) _ = Bad x
118 (>>=) (Ok x) fn = fn x
119 return = Ok
120 fail = Bad . strMsg
121
122 instance Functor (GenericResult a) where
123 fmap _ (Bad msg) = Bad msg
124 fmap fn (Ok val) = Ok (fn val)
125
126 instance (Error a, Monoid a) => MonadPlus (GenericResult a) where
127 mzero = Bad $ strMsg "zero Result when used as MonadPlus"
128 -- for mplus, when we 'add' two Bad values, we concatenate their
129 -- error descriptions
130 (Bad x) `mplus` (Bad y) = Bad (x `mappend` strMsg "; " `mappend` y)
131 (Bad _) `mplus` x = x
132 x@(Ok _) `mplus` _ = x
133
134 instance (Error a) => MonadError a (GenericResult a) where
135 throwError = Bad
136 {-# INLINE throwError #-}
137 catchError x h = genericResult h (const x) x
138 {-# INLINE catchError #-}
139
140 instance Applicative (GenericResult a) where
141 pure = Ok
142 (Bad f) <*> _ = Bad f
143 _ <*> (Bad x) = Bad x
144 (Ok f) <*> (Ok x) = Ok $ f x
145
146 instance (Error a, Monoid a) => Alternative (GenericResult a) where
147 empty = mzero
148 (<|>) = mplus
149
150 -- | This is a monad transformation for Result. It's implementation is
151 -- based on the implementations of MaybeT and ErrorT.
152 --
153 -- 'ResultT' is very similar to @ErrorT@, but with one subtle difference:
154 -- If 'mplus' combines two failing operations, errors of both of them
155 -- are combined.
156 newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}
157 deriving (Functor)
158
159 -- | Eliminates a 'ResultT' value given appropriate continuations
160 elimResultT :: (Monad m)
161 => (a -> ResultT a' m b')
162 -> (b -> ResultT a' m b')
163 -> ResultT a m b
164 -> ResultT a' m b'
165 elimResultT l r = ResultT . (runResultT . result <=< runResultT)
166 where
167 result (Ok x) = r x
168 result (Bad e) = l e
169 {-# INLINE elimResultT #-}
170
171 instance (Applicative m, Monad m, Error a) => Applicative (ResultT a m) where
172 pure = return
173 (<*>) = ap
174
175 instance (Monad m, Error a) => Monad (ResultT a m) where
176 fail err = ResultT (return . Bad $ strMsg err)
177 return = lift . return
178 (>>=) = flip (elimResultT throwError)
179
180 instance (Monad m, Error a) => MonadError a (ResultT a m) where
181 throwError = ResultT . return . Bad
182 catchError = catchErrorT
183
184 instance MonadTrans (ResultT a) where
185 lift = ResultT . liftM Ok
186
187 -- | The instance catches any 'IOError' using 'try' and converts it into an
188 -- error message using 'strMsg'.
189 --
190 -- This way, monadic code within 'ResultT' that uses solely 'liftIO' to
191 -- include 'IO' actions ensures that all IO exceptions are handled.
192 --
193 -- Other exceptions (see instances of 'Exception') are not currently handled.
194 -- This might be revised in the future.
195 instance (MonadIO m, Error a) => MonadIO (ResultT a m) where
196 liftIO = ResultT . liftIO
197 . liftM (either (failError . show) return)
198 . (try :: IO a -> IO (Either IOError a))
199
200 instance (MonadBase IO m, Error a) => MonadBase IO (ResultT a m) where
201 liftBase = ResultT . liftBase
202 . liftM (either (failError . show) return)
203 . (try :: IO a -> IO (Either IOError a))
204
205 instance (Error a) => MonadTransControl (ResultT a) where
206 #if MIN_VERSION_monad_control(1,0,0)
207 -- Needs Undecidable instances
208 type StT (ResultT a) b = GenericResult a b
209 liftWith f = ResultT . liftM return $ f runResultT
210 restoreT = ResultT
211 #else
212 newtype StT (ResultT a) b = StResultT { runStResultT :: GenericResult a b }
213 liftWith f = ResultT . liftM return $ f (liftM StResultT . runResultT)
214 restoreT = ResultT . liftM runStResultT
215 #endif
216 {-# INLINE liftWith #-}
217 {-# INLINE restoreT #-}
218
219 instance (Error a, MonadBaseControl IO m)
220 => MonadBaseControl IO (ResultT a m) where
221 #if MIN_VERSION_monad_control(1,0,0)
222 -- Needs Undecidable instances
223 type StM (ResultT a m) b
224 = ComposeSt (ResultT a) m b
225 liftBaseWith = defaultLiftBaseWith
226 restoreM = defaultRestoreM
227 #else
228 newtype StM (ResultT a m) b
229 = StMResultT { runStMResultT :: ComposeSt (ResultT a) m b }
230 liftBaseWith = defaultLiftBaseWith StMResultT
231 restoreM = defaultRestoreM runStMResultT
232 #endif
233 {-# INLINE liftBaseWith #-}
234 {-# INLINE restoreM #-}
235
236 instance (Monad m, Error a, Monoid a) => MonadPlus (ResultT a m) where
237 mzero = ResultT $ return mzero
238 -- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit
239 -- more complicated than 'mplus' of 'GenericResult'.
240 mplus x y = elimResultT combine return x
241 where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y)
242
243 instance (Alternative m, Monad m, Error a, Monoid a)
244 => Alternative (ResultT a m) where
245 empty = mzero
246 (<|>) = mplus
247
248 -- | Changes the error message of a result value, if present.
249 -- Note that since 'GenericResult' is also a 'MonadError', this function
250 -- is a generalization of
251 -- @(Error e') => (e' -> e) -> GenericResult e' a -> GenericResult e a@
252 withError :: (MonadError e m) => (e' -> e) -> GenericResult e' a -> m a
253 withError f = genericResult (throwError . f) return
254
255 -- | Changes the error message of a @ResultT@ value, if present.
256 withErrorT :: (Monad m, Error e)
257 => (e' -> e) -> ResultT e' m a -> ResultT e m a
258 withErrorT f = ResultT . liftM (withError f) . runResultT
259
260 -- | Lift a 'Result' value to any 'MonadError'. Since 'ResultT' is itself its
261 -- instance, it's a generalization of
262 -- @Monad m => GenericResult a b -> ResultT a m b@.
263 toError :: (MonadError e m) => GenericResult e a -> m a
264 toError = genericResult throwError return
265 {-# INLINE toError #-}
266
267 -- | Lift a 'ResultT' value into any 'MonadError' with the same base monad.
268 toErrorBase :: (MonadBase b m, MonadError e m) => ResultT e b a -> m a
269 toErrorBase = (toError =<<) . liftBase . runResultT
270 {-# INLINE toErrorBase #-}
271
272 -- | An alias for @withError strMsg@, which is often used to lift a pure error
273 -- to a monad stack. See also 'annotateResult'.
274 toErrorStr :: (MonadError e m, Error e) => Result a -> m a
275 toErrorStr = withError strMsg
276
277 -- | Run a given computation and if an error occurs, return it as `Left` of
278 -- `Either`.
279 -- This is a generalized version of 'try'.
280 tryError :: (MonadError e m) => m a -> m (Either e a)
281 tryError = flip catchError (return . Left) . liftM Right
282 {-# INLINE tryError #-}
283
284 -- | Converts a monadic result with a 'String' message into
285 -- a 'ResultT' with an arbitrary 'Error'.
286 --
287 -- Expects that the given action has already taken care of any possible
288 -- errors. In particular, if applied on @IO (Result a)@, any exceptions
289 -- should be handled by the given action.
290 --
291 -- See also 'toErrorStr'.
292 mkResultT :: (Monad m, Error e) => m (Result a) -> ResultT e m a
293 mkResultT = ResultT . liftM toErrorStr
294
295 -- | Simple checker for whether a 'GenericResult' is OK.
296 isOk :: GenericResult a b -> Bool
297 isOk (Ok _) = True
298 isOk _ = False
299
300 -- | Simple checker for whether a 'GenericResult' is a failure.
301 isBad :: GenericResult a b -> Bool
302 isBad = not . isOk
303
304 -- | Simple filter returning only OK values of GenericResult
305 justOk :: [GenericResult a b] -> [b]
306 justOk = mapMaybe (genericResult (const Nothing) Just)
307
308 -- | Simple filter returning only Bad values of GenericResult
309 justBad :: [GenericResult a b] -> [a]
310 justBad = mapMaybe (genericResult Just (const Nothing))
311
312 -- | Converter from Either to 'GenericResult'.
313 eitherToResult :: Either a b -> GenericResult a b
314 eitherToResult (Left s) = Bad s
315 eitherToResult (Right v) = Ok v
316
317 -- | Check if an either is Left. Equivalent to isLeft from Data.Either
318 -- version 4.7.0.0 or higher.
319 isLeft :: Either a b -> Bool
320 isLeft (Left _) = True
321 isLeft _ = False
322
323 -- | Check if an either is Right. Equivalent to isRight from Data.Either
324 -- version 4.7.0.0 or higher.
325 isRight :: Either a b -> Bool
326 isRight = not . isLeft
327
328 -- | Annotate an error with an ownership information, lifting it to a
329 -- 'MonadError'. Since 'Result' is an instance of 'MonadError' itself,
330 -- it's a generalization of type @String -> Result a -> Result a@.
331 -- See also 'toErrorStr'.
332 annotateResult :: (MonadError e m, Error e) => String -> Result a -> m a
333 annotateResult owner = toErrorStr . annotateError owner
334
335 -- | Annotate an error with an ownership information inside a 'MonadError'.
336 -- See also 'annotateResult'.
337 annotateError :: (MonadError e m, Error e, Monoid e) => String -> m a -> m a
338 annotateError owner =
339 flip catchError (throwError . mappend (strMsg $ owner ++ ": "))
340 {-# INLINE annotateError #-}
341
342 -- | Throws a 'String' message as an error in a 'MonadError'.
343 -- This is a generalization of 'Bad'.
344 -- It's similar to 'fail', but works within a 'MonadError', avoiding the
345 -- unsafe nature of 'fail'.
346 failError :: (MonadError e m, Error e) => String -> m a
347 failError = throwError . strMsg
348
349 -- | A synonym for @flip@ 'catchErrorT'.
350 handleErrorT :: (Monad m, Error e)
351 => (e' -> ResultT e m a) -> ResultT e' m a -> ResultT e m a
352 handleErrorT handler = elimResultT handler return
353 {-# INLINE handleErrorT #-}
354
355 -- | Catches an error in a @ResultT@ value. This is similar to 'catchError',
356 -- but in addition allows to change the error type.
357 catchErrorT :: (Monad m, Error e)
358 => ResultT e' m a -> (e' -> ResultT e m a) -> ResultT e m a
359 catchErrorT = flip handleErrorT
360 {-# INLINE catchErrorT #-}
361
362 -- | If the first computation fails, run the second one.
363 -- Unlike 'mplus' instance for 'ResultT', this doesn't require
364 -- the 'Monoid' constrait.
365 orElse :: (MonadError e m) => m a -> m a -> m a
366 orElse x y = catchError x (const y)
367
368 -- | Iterate while Ok.
369 iterateOk :: (a -> GenericResult b a) -> a -> [a]
370 iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a)
371
372 -- * Misc functionality
373
374 -- | Return the first result with a True condition, or the default otherwise.
375 select :: a -- ^ default result
376 -> [(Bool, a)] -- ^ list of \"condition, result\"
377 -> a -- ^ first result which has a True condition, or default
378 select def = maybe def snd . find fst
379
380 -- | Apply a function to the first element of a list, return the default
381 -- value, if the list is empty. This is just a convenient combination of
382 -- maybe and listToMaybe.
383 runListHead :: a -> (b -> a) -> [b] -> a
384 runListHead a f = maybe a f . listToMaybe
385
386 -- * Lookup of partial names functionality
387
388 -- | The priority of a match in a lookup result.
389 data MatchPriority = ExactMatch
390 | MultipleMatch
391 | PartialMatch
392 | FailMatch
393 deriving (Show, Enum, Eq, Ord)
394
395 -- | The result of a name lookup in a list.
396 data LookupResult = LookupResult
397 { lrMatchPriority :: MatchPriority -- ^ The result type
398 -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
399 , lrContent :: String
400 } deriving (Show)
401
402 -- | Lookup results have an absolute preference ordering.
403 instance Eq LookupResult where
404 (==) = (==) `on` lrMatchPriority
405
406 instance Ord LookupResult where
407 compare = compare `on` lrMatchPriority
408
409 -- | Check for prefix matches in names.
410 -- Implemented in Ganeti core utils.text.MatchNameComponent
411 -- as the regexp r"^%s(\..*)?$" % re.escape(key)
412 prefixMatch :: String -- ^ Lookup
413 -> String -- ^ Full name
414 -> Bool -- ^ Whether there is a prefix match
415 prefixMatch = isPrefixOf . (++ ".")
416
417 -- | Is the lookup priority a "good" one?
418 goodMatchPriority :: MatchPriority -> Bool
419 goodMatchPriority ExactMatch = True
420 goodMatchPriority PartialMatch = True
421 goodMatchPriority _ = False
422
423 -- | Is the lookup result an actual match?
424 goodLookupResult :: LookupResult -> Bool
425 goodLookupResult = goodMatchPriority . lrMatchPriority
426
427 -- | Compares a canonical name and a lookup string.
428 compareNameComponent :: String -- ^ Canonical (target) name
429 -> String -- ^ Partial (lookup) name
430 -> LookupResult -- ^ Result of the lookup
431 compareNameComponent cnl lkp =
432 select (LookupResult FailMatch lkp)
433 [ (cnl == lkp , LookupResult ExactMatch cnl)
434 , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
435 ]
436
437 -- | Lookup a string and choose the best result.
438 chooseLookupResult :: String -- ^ Lookup key
439 -> String -- ^ String to compare to the lookup key
440 -> LookupResult -- ^ Previous result
441 -> LookupResult -- ^ New result
442 chooseLookupResult lkp cstr old =
443 -- default: use class order to pick the minimum result
444 select (min new old)
445 -- special cases:
446 -- short circuit if the new result is an exact match
447 [ (lrMatchPriority new == ExactMatch, new)
448 -- if both are partial matches generate a multiple match
449 , (partial2, LookupResult MultipleMatch lkp)
450 ] where new = compareNameComponent cstr lkp
451 partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
452
453 -- | Find the canonical name for a lookup string in a list of names.
454 lookupName :: [String] -- ^ List of keys
455 -> String -- ^ Lookup string
456 -> LookupResult -- ^ Result of the lookup
457 lookupName l s = foldr (chooseLookupResult s)
458 (LookupResult FailMatch s) l
459
460 -- | Wrapper for a Haskell 'Set'
461 --
462 -- This type wraps a 'Set' and it is used in the Haskell to Python
463 -- opcode generation to transform a Haskell 'Set' into a Python 'list'
464 -- without duplicate elements.
465 newtype ListSet a = ListSet { unListSet :: Set a }
466 deriving (Eq, Show, Ord)
467
468 instance (Ord a, JSON a) => JSON (ListSet a) where
469 showJSON = JSON.showJSON . unListSet
470 readJSON = liftM ListSet . JSON.readJSON
471
472 emptyListSet :: ListSet a
473 emptyListSet = ListSet Set.empty