1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE TypeFamilies #-}
5 {-# LANGUAGE DeriveFunctor #-}
6 {-# LANGUAGE UndecidableInstances #-}
11 Copyright (C) 2009, 2010, 2011, 2012, 2015 Google Inc.
14 Redistribution and use in source and binary forms, with or without
15 modification, are permitted provided that the following conditions are
18 1. Redistributions of source code must retain the above copyright notice,
19 this list of conditions and the following disclaimer.
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.
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.
39 module Ganeti
.BasicTypes
53 , Error
(..) -- re-export from Control.Monad.Error
54 , MonadIO
(..) -- re-export from Control.Monad.IO.Class
78 , compareNameComponent
87 import Control
.Applicative
88 import Control
.Exception
(try)
90 import Control
.Monad
.Base
91 import Control
.Monad
.Error
.Class
92 import Control
.Monad
.Trans
93 import Control
.Monad
.Trans
.Control
95 import Data
.List
(find, isPrefixOf)
98 import qualified Data
.Set
as Set
(empty)
99 import Text
.JSON
(JSON
)
100 import qualified Text
.JSON
as JSON
(readJSON
, showJSON
)
101 #if MIN_VERSION_base
(4,6,0)
105 -- Remove after we require >= 1.8.58
106 -- See: https://github.com/ndmitchell/hlint/issues/24
107 {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}
109 -- | Generic monad for our error handling mechanisms.
110 data GenericResult a b
115 -- | Sum type structure of GenericResult.
116 genericResult
:: (a
-> c
) -> (b
-> c
) -> GenericResult a b
-> c
117 genericResult f _
(Bad a
) = f a
118 genericResult _ g
(Ok b
) = g b
119 {-# INLINE genericResult #-}
121 -- | Type alias for a string Result.
122 type Result
= GenericResult
String
124 -- | Type class for things that can be built from strings.
125 class FromString a
where
126 mkFromString
:: String -> a
128 -- | Trivial 'String' instance; requires FlexibleInstances extension
130 instance FromString
[Char] where
133 instance FromString
IOError where
134 mkFromString
= userError
136 -- | 'Monad' instance for 'GenericResult'.
137 instance (FromString a
) => Monad
(GenericResult a
) where
138 (>>=) (Bad x
) _
= Bad x
139 (>>=) (Ok x
) fn
= fn x
141 fail = Bad
. mkFromString
143 instance Functor
(GenericResult a
) where
144 fmap _
(Bad msg
) = Bad msg
145 fmap fn
(Ok val
) = Ok
(fn val
)
147 instance (FromString a
, Monoid a
) => Alternative
(GenericResult a
) where
148 empty = Bad
$ mkFromString
"zero Result when used as empty"
149 -- for mplus, when we 'add' two Bad values, we concatenate their
150 -- error descriptions
151 (Bad x
) <|> (Bad y
) = Bad
(x `mappend` mkFromString
"; " `mappend` y
)
155 instance (FromString a
, Monoid a
) => MonadPlus
(GenericResult a
) where
159 instance (FromString a
) => MonadError a
(GenericResult a
) where
161 {-# INLINE throwError #-}
162 catchError x h
= genericResult h
(const x
) x
163 {-# INLINE catchError #-}
165 instance Applicative
(GenericResult a
) where
167 (Bad f
) <*> _
= Bad f
168 _
<*> (Bad x
) = Bad x
169 (Ok f
) <*> (Ok x
) = Ok
$ f x
171 -- | This is a monad transformation for Result. It's implementation is
172 -- based on the implementations of MaybeT and ErrorT.
174 -- 'ResultT' is very similar to @ErrorT@, but with one subtle difference:
175 -- If 'mplus' combines two failing operations, errors of both of them
177 newtype ResultT a m b
= ResultT
{runResultT
:: m
(GenericResult a b
)}
179 -- | Eliminates a 'ResultT' value given appropriate continuations
180 elimResultT
:: (Monad m
)
181 => (a
-> ResultT a
' m b
')
182 -> (b
-> ResultT a
' m b
')
185 elimResultT l r
= ResultT
. (runResultT
. result
<=< runResultT
)
189 {-# INLINE elimResultT #-}
191 instance (Monad m
) => Functor
(ResultT a m
) where
192 fmap f
= ResultT
. liftM (fmap f
) . runResultT
194 instance (Monad m
, FromString a
) => Applicative
(ResultT a m
) where
198 instance (Monad m
, FromString a
) => Monad
(ResultT a m
) where
199 fail err
= ResultT
(return . Bad
$ mkFromString err
)
200 return = lift
. return
201 (>>=) = flip (elimResultT throwError
)
203 instance (Monad m
, FromString a
) => MonadError a
(ResultT a m
) where
204 throwError
= ResultT
. return . Bad
205 catchError
= catchErrorT
207 instance MonadTrans
(ResultT a
) where
208 lift
= ResultT
. liftM Ok
210 -- | The instance catches any 'IOError' using 'try' and converts it into an
211 -- error message using 'mkFromString'.
213 -- This way, monadic code within 'ResultT' that uses solely 'liftIO' to
214 -- include 'IO' actions ensures that all IO exceptions are handled.
216 -- Other exceptions (see instances of 'Exception') are not currently handled.
217 -- This might be revised in the future.
218 instance (MonadIO m
, FromString a
) => MonadIO
(ResultT a m
) where
219 liftIO
= ResultT
. liftIO
220 . liftM (either (failError
. show) return)
221 . (try :: IO a
-> IO (Either IOError a
))
223 instance (MonadBase
IO m
, FromString a
) => MonadBase
IO (ResultT a m
) where
224 liftBase
= ResultT
. liftBase
225 . liftM (either (failError
. show) return)
226 . (try :: IO a
-> IO (Either IOError a
))
228 instance (FromString a
) => MonadTransControl
(ResultT a
) where
229 #if MIN_VERSION_monad_control
(1,0,0)
230 -- Needs Undecidable instances
231 type StT
(ResultT a
) b
= GenericResult a b
232 liftWith f
= ResultT
. liftM return $ f runResultT
235 newtype StT
(ResultT a
) b
= StResultT
{ runStResultT
:: GenericResult a b
}
236 liftWith f
= ResultT
. liftM return $ f
(liftM StResultT
. runResultT
)
237 restoreT
= ResultT
. liftM runStResultT
239 {-# INLINE liftWith #-}
240 {-# INLINE restoreT #-}
242 instance (FromString a
, MonadBaseControl
IO m
)
243 => MonadBaseControl
IO (ResultT a m
) where
244 #if MIN_VERSION_monad_control
(1,0,0)
245 -- Needs Undecidable instances
246 type StM
(ResultT a m
) b
247 = ComposeSt
(ResultT a
) m b
248 liftBaseWith
= defaultLiftBaseWith
249 restoreM
= defaultRestoreM
251 newtype StM
(ResultT a m
) b
252 = StMResultT
{ runStMResultT
:: ComposeSt
(ResultT a
) m b
}
253 liftBaseWith
= defaultLiftBaseWith StMResultT
254 restoreM
= defaultRestoreM runStMResultT
256 {-# INLINE liftBaseWith #-}
257 {-# INLINE restoreM #-}
259 instance (Monad m
, FromString a
, Monoid a
)
260 => Alternative
(ResultT a m
) where
261 empty = ResultT
$ return mzero
262 -- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit
263 -- more complicated than 'mplus' of 'GenericResult'.
264 x
<|> y
= elimResultT combine
return x
265 where combine x
' = ResultT
$ liftM (mplus
(Bad x
')) (runResultT y
)
267 instance (Monad m
, FromString a
, Monoid a
)
268 => MonadPlus
(ResultT a m
) where
272 -- | Changes the error message of a result value, if present.
273 -- Note that since 'GenericResult' is also a 'MonadError', this function
274 -- is a generalization of
275 -- @(Error e') => (e' -> e) -> GenericResult e' a -> GenericResult e a@
276 withError
:: (MonadError e m
) => (e
' -> e
) -> GenericResult e
' a
-> m a
277 withError f
= genericResult
(throwError
. f
) return
279 -- | Changes the error message of a @ResultT@ value, if present.
280 withErrorT
:: (Monad m
, FromString e
)
281 => (e
' -> e
) -> ResultT e
' m a
-> ResultT e m a
282 withErrorT f
= ResultT
. liftM (withError f
) . runResultT
284 -- | Lift a 'Result' value to any 'MonadError'. Since 'ResultT' is itself its
285 -- instance, it's a generalization of
286 -- @Monad m => GenericResult a b -> ResultT a m b@.
287 toError
:: (MonadError e m
) => GenericResult e a
-> m a
288 toError
= genericResult throwError
return
289 {-# INLINE toError #-}
291 -- | Lift a 'ResultT' value into any 'MonadError' with the same base monad.
292 toErrorBase
:: (MonadBase b m
, MonadError e m
) => ResultT e b a
-> m a
293 toErrorBase
= (toError
=<<) . liftBase
. runResultT
294 {-# INLINE toErrorBase #-}
296 -- | An alias for @withError mkFromString@, which is often
297 -- used to lift a pure error to a monad stack. See also 'annotateResult'.
298 toErrorStr
:: (MonadError e m
, FromString e
) => Result a
-> m a
299 toErrorStr
= withError mkFromString
301 -- | Run a given computation and if an error occurs, return it as `Left` of
303 -- This is a generalized version of 'try'.
304 tryError
:: (MonadError e m
) => m a
-> m
(Either e a
)
305 tryError
= flip catchError
(return . Left
) . liftM Right
306 {-# INLINE tryError #-}
308 -- | Converts a monadic result with a 'String' message into
309 -- a 'ResultT' with an arbitrary 'Error'.
311 -- Expects that the given action has already taken care of any possible
312 -- errors. In particular, if applied on @IO (Result a)@, any exceptions
313 -- should be handled by the given action.
315 -- See also 'toErrorStr'.
316 mkResultT
:: (Monad m
, FromString e
) => m
(Result a
) -> ResultT e m a
317 mkResultT
= ResultT
. liftM toErrorStr
319 -- | Generalisation of mkResultT accepting any showable failures.
320 mkResultT
' :: (Monad m
, FromString e
, Show s
)
321 => m
(GenericResult s a
) -> ResultT e m a
322 mkResultT
' = mkResultT
. liftM (genericResult
(Bad
. show) Ok
)
324 -- | Generalisation of mkResultT accepting any showable failures.
325 mkResultTEither
:: (Monad m
, FromString e
, Show s
)
326 => m
(Either s a
) -> ResultT e m a
327 mkResultTEither
= mkResultT
. liftM (either (Bad
. show) Ok
)
329 -- | Simple checker for whether a 'GenericResult' is OK.
330 isOk
:: GenericResult a b
-> Bool
334 -- | Simple checker for whether a 'GenericResult' is a failure.
335 isBad
:: GenericResult a b
-> Bool
338 -- | Simple filter returning only OK values of GenericResult
339 justOk
:: [GenericResult a b
] -> [b
]
340 justOk
= mapMaybe (genericResult
(const Nothing
) Just
)
342 -- | Simple filter returning only Bad values of GenericResult
343 justBad
:: [GenericResult a b
] -> [a
]
344 justBad
= mapMaybe (genericResult Just
(const Nothing
))
346 -- | Converter from Either to 'GenericResult'.
347 eitherToResult
:: Either a b
-> GenericResult a b
348 eitherToResult
(Left s
) = Bad s
349 eitherToResult
(Right v
) = Ok v
351 -- | Check if an either is Left. Equivalent to isLeft from Data.Either
352 -- version 4.7.0.0 or higher.
353 isLeft
:: Either a b
-> Bool
354 isLeft
(Left _
) = True
357 -- | Check if an either is Right. Equivalent to isRight from Data.Either
358 -- version 4.7.0.0 or higher.
359 isRight
:: Either a b
-> Bool
360 isRight
= not . isLeft
362 -- | Annotate an error with an ownership information, lifting it to a
363 -- 'MonadError'. Since 'Result' is an instance of 'MonadError' itself,
364 -- it's a generalization of type @String -> Result a -> Result a@.
365 -- See also 'toErrorStr'.
366 annotateResult
:: (MonadError e m
, FromString e
) => String -> Result a
-> m a
367 annotateResult owner
= toErrorStr
. annotateError owner
369 -- | Annotate an error with an ownership information inside a 'MonadError'.
370 -- See also 'annotateResult'.
371 annotateError
:: (MonadError e m
, FromString e
, Monoid e
)
372 => String -> m a
-> m a
373 annotateError owner
=
374 flip catchError
(throwError
. mappend
(mkFromString
$ owner
++ ": "))
375 {-# INLINE annotateError #-}
377 -- | Throws a 'String' message as an error in a 'MonadError'.
378 -- This is a generalization of 'Bad'.
379 -- It's similar to 'fail', but works within a 'MonadError', avoiding the
380 -- unsafe nature of 'fail'.
381 failError
:: (MonadError e m
, FromString e
) => String -> m a
382 failError
= throwError
. mkFromString
384 -- | A synonym for @flip@ 'catchErrorT'.
385 handleErrorT
:: (Monad m
, FromString e
)
386 => (e
' -> ResultT e m a
) -> ResultT e
' m a
-> ResultT e m a
387 handleErrorT handler
= elimResultT handler
return
388 {-# INLINE handleErrorT #-}
390 -- | Catches an error in a @ResultT@ value. This is similar to 'catchError',
391 -- but in addition allows to change the error type.
392 catchErrorT
:: (Monad m
, FromString e
)
393 => ResultT e
' m a
-> (e
' -> ResultT e m a
) -> ResultT e m a
394 catchErrorT
= flip handleErrorT
395 {-# INLINE catchErrorT #-}
397 -- | If the first computation fails, run the second one.
398 -- Unlike 'mplus' instance for 'ResultT', this doesn't require
399 -- the 'Monoid' constrait.
400 orElse
:: (MonadError e m
) => m a
-> m a
-> m a
401 orElse x y
= catchError x
(const y
)
403 -- | Iterate while Ok.
404 iterateOk
:: (a
-> GenericResult b a
) -> a
-> [a
]
405 iterateOk f a
= genericResult
(const []) ((:) a
. iterateOk f
) (f a
)
407 -- * Misc functionality
409 -- | Return the first result with a True condition, or the default otherwise.
410 select
:: a
-- ^ default result
411 -> [(Bool, a
)] -- ^ list of \"condition, result\"
412 -> a
-- ^ first result which has a True condition, or default
413 select def
= maybe def
snd . find fst
415 -- | Apply a function to the first element of a list, return the default
416 -- value, if the list is empty. This is just a convenient combination of
417 -- maybe and listToMaybe.
418 runListHead
:: a
-> (b
-> a
) -> [b
] -> a
419 runListHead a f
= maybe a f
. listToMaybe
421 -- * Lookup of partial names functionality
423 -- | The priority of a match in a lookup result.
424 data MatchPriority
= ExactMatch
428 deriving (Show, Enum
, Eq
, Ord
)
430 -- | The result of a name lookup in a list.
431 data LookupResult
= LookupResult
432 { lrMatchPriority
:: MatchPriority
-- ^ The result type
433 -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
434 , lrContent
:: String
437 -- | Lookup results have an absolute preference ordering.
438 instance Eq LookupResult
where
439 (==) = (==) `on` lrMatchPriority
441 instance Ord LookupResult
where
442 compare = compare `on` lrMatchPriority
444 -- | Check for prefix matches in names.
445 -- Implemented in Ganeti core utils.text.MatchNameComponent
446 -- as the regexp r"^%s(\..*)?$" % re.escape(key)
447 prefixMatch
:: String -- ^ Lookup
448 -> String -- ^ Full name
449 -> Bool -- ^ Whether there is a prefix match
450 prefixMatch
= isPrefixOf . (++ ".")
452 -- | Is the lookup priority a "good" one?
453 goodMatchPriority
:: MatchPriority
-> Bool
454 goodMatchPriority ExactMatch
= True
455 goodMatchPriority PartialMatch
= True
456 goodMatchPriority _
= False
458 -- | Is the lookup result an actual match?
459 goodLookupResult
:: LookupResult
-> Bool
460 goodLookupResult
= goodMatchPriority
. lrMatchPriority
462 -- | Compares a canonical name and a lookup string.
463 compareNameComponent
:: String -- ^ Canonical (target) name
464 -> String -- ^ Partial (lookup) name
465 -> LookupResult
-- ^ Result of the lookup
466 compareNameComponent cnl lkp
=
467 select
(LookupResult FailMatch lkp
)
468 [ (cnl
== lkp
, LookupResult ExactMatch cnl
)
469 , (prefixMatch lkp cnl
, LookupResult PartialMatch cnl
)
472 -- | Lookup a string and choose the best result.
473 chooseLookupResult
:: String -- ^ Lookup key
474 -> String -- ^ String to compare to the lookup key
475 -> LookupResult
-- ^ Previous result
476 -> LookupResult
-- ^ New result
477 chooseLookupResult lkp cstr old
=
478 -- default: use class order to pick the minimum result
481 -- short circuit if the new result is an exact match
482 [ (lrMatchPriority new
== ExactMatch
, new
)
483 -- if both are partial matches generate a multiple match
484 , (partial2
, LookupResult MultipleMatch lkp
)
485 ] where new
= compareNameComponent cstr lkp
486 partial2
= all ((PartialMatch
==) . lrMatchPriority
) [old
, new
]
488 -- | Find the canonical name for a lookup string in a list of names.
489 lookupName
:: [String] -- ^ List of keys
490 -> String -- ^ Lookup string
491 -> LookupResult
-- ^ Result of the lookup
492 lookupName l s
= foldr (chooseLookupResult s
)
493 (LookupResult FailMatch s
) l
495 -- | Wrapper for a Haskell 'Set'
497 -- This type wraps a 'Set' and it is used in the Haskell to Python
498 -- opcode generation to transform a Haskell 'Set' into a Python 'list'
499 -- without duplicate elements.
500 newtype ListSet a
= ListSet
{ unListSet
:: Set a
}
501 deriving (Eq
, Show, Ord
)
503 instance (Ord a
, JSON a
) => JSON
(ListSet a
) where
504 showJSON
= JSON
.showJSON
. unListSet
505 readJSON
= liftM ListSet
. JSON
.readJSON
507 emptyListSet
:: ListSet a
508 emptyListSet
= ListSet Set
.empty
510 #if MIN_VERSION_base
(4,6,0)
511 -- Down already defined in Data.Ord
513 -- Copyright : (c) The University of Glasgow 2005
514 -- License : BSD-style
516 newtype Down a
= Down a
deriving (Eq
, Show, Read)
518 instance Ord a
=> Ord
(Down a
) where
519 compare (Down x
) (Down y
) = y `
compare` x
521 {- License text of the above code fragment:
523 The Glasgow Haskell Compiler License
525 Copyright 2004, The University Court of the University of Glasgow.
528 Redistribution and use in source and binary forms, with or without
529 modification, are permitted provided that the following conditions are met:
531 - Redistributions of source code must retain the above copyright notice,
532 this list of conditions and the following disclaimer.
534 - Redistributions in binary form must reproduce the above copyright notice,
535 this list of conditions and the following disclaimer in the documentation
536 and/or other materials provided with the distribution.
538 - Neither name of the University nor the names of its contributors may be
539 used to endorse or promote products derived from this software without
540 specific prior written permission.
542 THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
543 GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
544 INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
545 FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
546 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
547 FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
548 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
549 SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
550 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
551 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
552 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH