1 {-# LANGUAGE FlexibleInstances #-}
5 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful, but
13 WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 module Ganeti.BasicTypes
41 , compareNameComponent
44 import Control.Applicative
46 import Control.Monad.Trans
50 -- | Generic monad for our error handling mechanisms.
51 data GenericResult a b
56 -- | Type alias for a string Result.
57 type Result = GenericResult String
59 -- | Type class for things that can be built from strings.
60 class FromString a where
61 mkFromString :: String -> a
63 -- | Trivial 'String' instance; requires FlexibleInstances extension
65 instance FromString [Char] where
68 -- | 'Monad' instance for 'GenericResult'.
69 instance (FromString a) => Monad (GenericResult a) where
70 (>>=) (Bad x) _ = Bad x
71 (>>=) (Ok x) fn = fn x
73 fail = Bad . mkFromString
75 instance Functor (GenericResult a) where
76 fmap _ (Bad msg) = Bad msg
77 fmap fn (Ok val) = Ok (fn val)
79 instance MonadPlus (GenericResult String) where
80 mzero = Bad "zero Result when used as MonadPlus"
81 -- for mplus, when we 'add' two Bad values, we concatenate their
83 (Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y)
85 x@(Ok _) `mplus` _ = x
87 instance Applicative (GenericResult a) where
91 (Ok f) <*> (Ok x) = Ok $ f x
93 -- | This is a monad transformation for Result. It's implementation is
94 -- based on the implementations of MaybeT and ErrorT.
95 newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}
97 instance (Monad m, FromString a) => Monad (ResultT a m) where
98 fail err = ResultT (return . Bad $ mkFromString err)
99 return = lift . return
100 x >>= f = ResultT $ do
103 Ok val -> runResultT $ f val
104 Bad err -> return $ Bad err
106 instance MonadTrans (ResultT a) where
107 lift x = ResultT (liftM Ok x)
109 instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where
110 liftIO = lift . liftIO
112 -- | Lift a `Result` value to a `ResultT`.
113 resultT :: Monad m => GenericResult a b -> ResultT a m b
114 resultT = ResultT . return
116 -- | Simple checker for whether a 'GenericResult' is OK.
117 isOk :: GenericResult a b -> Bool
121 -- | Simple checker for whether a 'GenericResult' is a failure.
122 isBad :: GenericResult a b -> Bool
125 -- | Converter from Either to 'GenericResult'.
126 eitherToResult :: Either a b -> GenericResult a b
127 eitherToResult (Left s) = Bad s
128 eitherToResult (Right v) = Ok v
130 -- | Annotate a Result with an ownership information.
131 annotateResult :: String -> Result a -> Result a
132 annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
133 annotateResult _ v = v
135 -- * Misc functionality
137 -- | Return the first result with a True condition, or the default otherwise.
138 select :: a -- ^ default result
139 -> [(Bool, a)] -- ^ list of \"condition, result\"
140 -> a -- ^ first result which has a True condition, or default
141 select def = maybe def snd . find fst
143 -- * Lookup of partial names functionality
145 -- | The priority of a match in a lookup result.
146 data MatchPriority = ExactMatch
150 deriving (Show, Enum, Eq, Ord)
152 -- | The result of a name lookup in a list.
153 data LookupResult = LookupResult
154 { lrMatchPriority :: MatchPriority -- ^ The result type
155 -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
156 , lrContent :: String
159 -- | Lookup results have an absolute preference ordering.
160 instance Eq LookupResult where
161 (==) = (==) `on` lrMatchPriority
163 instance Ord LookupResult where
164 compare = compare `on` lrMatchPriority
166 -- | Check for prefix matches in names.
167 -- Implemented in Ganeti core utils.text.MatchNameComponent
168 -- as the regexp r"^%s(\..*)?$" % re.escape(key)
169 prefixMatch :: String -- ^ Lookup
170 -> String -- ^ Full name
171 -> Bool -- ^ Whether there is a prefix match
172 prefixMatch = isPrefixOf . (++ ".")
174 -- | Is the lookup priority a "good" one?
175 goodMatchPriority :: MatchPriority -> Bool
176 goodMatchPriority ExactMatch = True
177 goodMatchPriority PartialMatch = True
178 goodMatchPriority _ = False
180 -- | Is the lookup result an actual match?
181 goodLookupResult :: LookupResult -> Bool
182 goodLookupResult = goodMatchPriority . lrMatchPriority
184 -- | Compares a canonical name and a lookup string.
185 compareNameComponent :: String -- ^ Canonical (target) name
186 -> String -- ^ Partial (lookup) name
187 -> LookupResult -- ^ Result of the lookup
188 compareNameComponent cnl lkp =
189 select (LookupResult FailMatch lkp)
190 [ (cnl == lkp , LookupResult ExactMatch cnl)
191 , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
194 -- | Lookup a string and choose the best result.
195 chooseLookupResult :: String -- ^ Lookup key
196 -> String -- ^ String to compare to the lookup key
197 -> LookupResult -- ^ Previous result
198 -> LookupResult -- ^ New result
199 chooseLookupResult lkp cstr old =
200 -- default: use class order to pick the minimum result
203 -- short circuit if the new result is an exact match
204 [ (lrMatchPriority new == ExactMatch, new)
205 -- if both are partial matches generate a multiple match
206 , (partial2, LookupResult MultipleMatch lkp)
207 ] where new = compareNameComponent cstr lkp
208 partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
210 -- | Find the canonical name for a lookup string in a list of names.
211 lookupName :: [String] -- ^ List of keys
212 -> String -- ^ Lookup string
213 -> LookupResult -- ^ Result of the lookup
214 lookupName l s = foldr (chooseLookupResult s)
215 (LookupResult FailMatch s) l