| {-# LANGUAGE FlexibleInstances #-} |
| |
| {- |
| |
| Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are |
| met: |
| |
| 1. Redistributions of source code must retain the above copyright notice, |
| this list of conditions and the following disclaimer. |
| |
| 2. Redistributions in binary form must reproduce the above copyright |
| notice, this list of conditions and the following disclaimer in the |
| documentation and/or other materials provided with the distribution. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS |
| IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED |
| TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR |
| PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR |
| CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, |
| EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, |
| PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR |
| PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF |
| LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING |
| NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS |
| SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| |
| -} |
| |
| module Ganeti.BasicTypes |
| ( GenericResult(..) |
| , genericResult |
| , Result |
| , ResultT(..) |
| , resultT |
| , FromString(..) |
| , isOk |
| , isBad |
| , eitherToResult |
| , annotateResult |
| , iterateOk |
| , select |
| , runListHead |
| , LookupResult(..) |
| , MatchPriority(..) |
| , lookupName |
| , goodLookupResult |
| , goodMatchPriority |
| , prefixMatch |
| , compareNameComponent |
| , ListSet(..) |
| , emptyListSet |
| ) where |
| |
| import Control.Applicative |
| import Control.Monad |
| import Control.Monad.Trans |
| import Data.Function |
| import Data.List |
| import Data.Maybe (listToMaybe) |
| import Data.Set (Set) |
| import qualified Data.Set as Set (empty) |
| import Text.JSON (JSON) |
| import qualified Text.JSON as JSON (readJSON, showJSON) |
| |
| -- | Generic monad for our error handling mechanisms. |
| data GenericResult a b |
| = Bad a |
| | Ok b |
| deriving (Show, Eq) |
| |
| -- | Sum type structure of GenericResult. |
| genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c |
| genericResult f _ (Bad a) = f a |
| genericResult _ g (Ok b) = g b |
| |
| -- | Type alias for a string Result. |
| type Result = GenericResult String |
| |
| -- | Type class for things that can be built from strings. |
| class FromString a where |
| mkFromString :: String -> a |
| |
| -- | Trivial 'String' instance; requires FlexibleInstances extension |
| -- though. |
| instance FromString [Char] where |
| mkFromString = id |
| |
| -- | 'Monad' instance for 'GenericResult'. |
| instance (FromString a) => Monad (GenericResult a) where |
| (>>=) (Bad x) _ = Bad x |
| (>>=) (Ok x) fn = fn x |
| return = Ok |
| fail = Bad . mkFromString |
| |
| instance Functor (GenericResult a) where |
| fmap _ (Bad msg) = Bad msg |
| fmap fn (Ok val) = Ok (fn val) |
| |
| instance MonadPlus (GenericResult String) where |
| mzero = Bad "zero Result when used as MonadPlus" |
| -- for mplus, when we 'add' two Bad values, we concatenate their |
| -- error descriptions |
| (Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y) |
| (Bad _) `mplus` x = x |
| x@(Ok _) `mplus` _ = x |
| |
| instance Applicative (GenericResult a) where |
| pure = Ok |
| (Bad f) <*> _ = Bad f |
| _ <*> (Bad x) = Bad x |
| (Ok f) <*> (Ok x) = Ok $ f x |
| |
| -- | This is a monad transformation for Result. It's implementation is |
| -- based on the implementations of MaybeT and ErrorT. |
| newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)} |
| |
| instance (Monad m, FromString a) => Monad (ResultT a m) where |
| fail err = ResultT (return . Bad $ mkFromString err) |
| return = lift . return |
| x >>= f = ResultT $ do |
| a <- runResultT x |
| case a of |
| Ok val -> runResultT $ f val |
| Bad err -> return $ Bad err |
| |
| instance MonadTrans (ResultT a) where |
| lift x = ResultT (liftM Ok x) |
| |
| instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where |
| liftIO = lift . liftIO |
| |
| -- | Lift a `Result` value to a `ResultT`. |
| resultT :: Monad m => GenericResult a b -> ResultT a m b |
| resultT = ResultT . return |
| |
| -- | Simple checker for whether a 'GenericResult' is OK. |
| isOk :: GenericResult a b -> Bool |
| isOk (Ok _) = True |
| isOk _ = False |
| |
| -- | Simple checker for whether a 'GenericResult' is a failure. |
| isBad :: GenericResult a b -> Bool |
| isBad = not . isOk |
| |
| -- | Converter from Either to 'GenericResult'. |
| eitherToResult :: Either a b -> GenericResult a b |
| eitherToResult (Left s) = Bad s |
| eitherToResult (Right v) = Ok v |
| |
| -- | Annotate a Result with an ownership information. |
| annotateResult :: String -> Result a -> Result a |
| annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s |
| annotateResult _ v = v |
| |
| -- | Iterate while Ok. |
| iterateOk :: (a -> GenericResult b a) -> a -> [a] |
| iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a) |
| |
| -- * Misc functionality |
| |
| -- | Return the first result with a True condition, or the default otherwise. |
| select :: a -- ^ default result |
| -> [(Bool, a)] -- ^ list of \"condition, result\" |
| -> a -- ^ first result which has a True condition, or default |
| select def = maybe def snd . find fst |
| |
| -- | Apply a function to the first element of a list, return the default |
| -- value, if the list is empty. This is just a convenient combination of |
| -- maybe and listToMaybe. |
| runListHead :: a -> (b -> a) -> [b] -> a |
| runListHead a f = maybe a f . listToMaybe |
| |
| -- * Lookup of partial names functionality |
| |
| -- | The priority of a match in a lookup result. |
| data MatchPriority = ExactMatch |
| | MultipleMatch |
| | PartialMatch |
| | FailMatch |
| deriving (Show, Enum, Eq, Ord) |
| |
| -- | The result of a name lookup in a list. |
| data LookupResult = LookupResult |
| { lrMatchPriority :: MatchPriority -- ^ The result type |
| -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise |
| , lrContent :: String |
| } deriving (Show) |
| |
| -- | Lookup results have an absolute preference ordering. |
| instance Eq LookupResult where |
| (==) = (==) `on` lrMatchPriority |
| |
| instance Ord LookupResult where |
| compare = compare `on` lrMatchPriority |
| |
| -- | Check for prefix matches in names. |
| -- Implemented in Ganeti core utils.text.MatchNameComponent |
| -- as the regexp r"^%s(\..*)?$" % re.escape(key) |
| prefixMatch :: String -- ^ Lookup |
| -> String -- ^ Full name |
| -> Bool -- ^ Whether there is a prefix match |
| prefixMatch = isPrefixOf . (++ ".") |
| |
| -- | Is the lookup priority a "good" one? |
| goodMatchPriority :: MatchPriority -> Bool |
| goodMatchPriority ExactMatch = True |
| goodMatchPriority PartialMatch = True |
| goodMatchPriority _ = False |
| |
| -- | Is the lookup result an actual match? |
| goodLookupResult :: LookupResult -> Bool |
| goodLookupResult = goodMatchPriority . lrMatchPriority |
| |
| -- | Compares a canonical name and a lookup string. |
| compareNameComponent :: String -- ^ Canonical (target) name |
| -> String -- ^ Partial (lookup) name |
| -> LookupResult -- ^ Result of the lookup |
| compareNameComponent cnl lkp = |
| select (LookupResult FailMatch lkp) |
| [ (cnl == lkp , LookupResult ExactMatch cnl) |
| , (prefixMatch lkp cnl , LookupResult PartialMatch cnl) |
| ] |
| |
| -- | Lookup a string and choose the best result. |
| chooseLookupResult :: String -- ^ Lookup key |
| -> String -- ^ String to compare to the lookup key |
| -> LookupResult -- ^ Previous result |
| -> LookupResult -- ^ New result |
| chooseLookupResult lkp cstr old = |
| -- default: use class order to pick the minimum result |
| select (min new old) |
| -- special cases: |
| -- short circuit if the new result is an exact match |
| [ (lrMatchPriority new == ExactMatch, new) |
| -- if both are partial matches generate a multiple match |
| , (partial2, LookupResult MultipleMatch lkp) |
| ] where new = compareNameComponent cstr lkp |
| partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new] |
| |
| -- | Find the canonical name for a lookup string in a list of names. |
| lookupName :: [String] -- ^ List of keys |
| -> String -- ^ Lookup string |
| -> LookupResult -- ^ Result of the lookup |
| lookupName l s = foldr (chooseLookupResult s) |
| (LookupResult FailMatch s) l |
| |
| -- | Wrapper for a Haskell 'Set' |
| -- |
| -- This type wraps a 'Set' and it is used in the Haskell to Python |
| -- opcode generation to transform a Haskell 'Set' into a Python 'list' |
| -- without duplicate elements. |
| newtype ListSet a = ListSet { unListSet :: Set a } |
| deriving (Eq, Show) |
| |
| instance (Ord a, JSON a) => JSON (ListSet a) where |
| showJSON = JSON.showJSON . unListSet |
| readJSON = liftM ListSet . JSON.readJSON |
| |
| emptyListSet :: ListSet a |
| emptyListSet = ListSet Set.empty |