root / src / Ganeti / BasicTypes.hs @ ea174b21
History | View | Annotate | Download (9.3 kB)
1 | 95e683c6 | Petr Pudlak | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} |
---|---|---|---|
2 | 93be1ced | Iustin Pop | |
3 | 0c37d1e4 | Iustin Pop | {- |
4 | 0c37d1e4 | Iustin Pop | |
5 | 1091021c | Iustin Pop | Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
6 | 0c37d1e4 | Iustin Pop | |
7 | 0c37d1e4 | Iustin Pop | This program is free software; you can redistribute it and/or modify |
8 | 0c37d1e4 | Iustin Pop | it under the terms of the GNU General Public License as published by |
9 | 0c37d1e4 | Iustin Pop | the Free Software Foundation; either version 2 of the License, or |
10 | 0c37d1e4 | Iustin Pop | (at your option) any later version. |
11 | 0c37d1e4 | Iustin Pop | |
12 | 0c37d1e4 | Iustin Pop | This program is distributed in the hope that it will be useful, but |
13 | 0c37d1e4 | Iustin Pop | WITHOUT ANY WARRANTY; without even the implied warranty of |
14 | 0c37d1e4 | Iustin Pop | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
15 | 0c37d1e4 | Iustin Pop | General Public License for more details. |
16 | 0c37d1e4 | Iustin Pop | |
17 | 0c37d1e4 | Iustin Pop | You should have received a copy of the GNU General Public License |
18 | 0c37d1e4 | Iustin Pop | along with this program; if not, write to the Free Software |
19 | 0c37d1e4 | Iustin Pop | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
20 | 0c37d1e4 | Iustin Pop | 02110-1301, USA. |
21 | 0c37d1e4 | Iustin Pop | |
22 | 0c37d1e4 | Iustin Pop | -} |
23 | 0c37d1e4 | Iustin Pop | |
24 | 0c37d1e4 | Iustin Pop | module Ganeti.BasicTypes |
25 | 93be1ced | Iustin Pop | ( GenericResult(..) |
26 | b74ebe44 | Klaus Aehlig | , genericResult |
27 | 93be1ced | Iustin Pop | , Result |
28 | d71fbcc5 | Agata Murawska | , ResultT(..) |
29 | d71fbcc5 | Agata Murawska | , resultT |
30 | 93be1ced | Iustin Pop | , FromString(..) |
31 | 0c37d1e4 | Iustin Pop | , isOk |
32 | 0c37d1e4 | Iustin Pop | , isBad |
33 | 9491766c | Hrvoje Ribicic | , justOk |
34 | ea128e20 | Klaus Aehlig | , justBad |
35 | 0c37d1e4 | Iustin Pop | , eitherToResult |
36 | f3f76ccc | Iustin Pop | , annotateResult |
37 | b1c772fd | Klaus Aehlig | , iterateOk |
38 | 2fc5653f | Iustin Pop | , select |
39 | 2fc5653f | Iustin Pop | , LookupResult(..) |
40 | 2fc5653f | Iustin Pop | , MatchPriority(..) |
41 | 2fc5653f | Iustin Pop | , lookupName |
42 | 2fc5653f | Iustin Pop | , goodLookupResult |
43 | 2fc5653f | Iustin Pop | , goodMatchPriority |
44 | 2fc5653f | Iustin Pop | , prefixMatch |
45 | 2fc5653f | Iustin Pop | , compareNameComponent |
46 | 4651c69f | Jose A. Lopes | , ListSet(..) |
47 | 4651c69f | Jose A. Lopes | , emptyListSet |
48 | 0c37d1e4 | Iustin Pop | ) where |
49 | 0c37d1e4 | Iustin Pop | |
50 | 25779212 | Iustin Pop | import Control.Applicative |
51 | 0c37d1e4 | Iustin Pop | import Control.Monad |
52 | 95e683c6 | Petr Pudlak | import Control.Monad.Error.Class |
53 | d71fbcc5 | Agata Murawska | import Control.Monad.Trans |
54 | 2fc5653f | Iustin Pop | import Data.Function |
55 | 2fc5653f | Iustin Pop | import Data.List |
56 | ea128e20 | Klaus Aehlig | import Data.Maybe |
57 | 95e683c6 | Petr Pudlak | import Data.Monoid |
58 | 4651c69f | Jose A. Lopes | import Data.Set (Set) |
59 | 4651c69f | Jose A. Lopes | import qualified Data.Set as Set (empty) |
60 | 4651c69f | Jose A. Lopes | import Text.JSON (JSON) |
61 | 4651c69f | Jose A. Lopes | import qualified Text.JSON as JSON (readJSON, showJSON) |
62 | 0c37d1e4 | Iustin Pop | |
63 | 93be1ced | Iustin Pop | -- | Generic monad for our error handling mechanisms. |
64 | 93be1ced | Iustin Pop | data GenericResult a b |
65 | 93be1ced | Iustin Pop | = Bad a |
66 | 93be1ced | Iustin Pop | | Ok b |
67 | 139c0683 | Iustin Pop | deriving (Show, Eq) |
68 | 0c37d1e4 | Iustin Pop | |
69 | b74ebe44 | Klaus Aehlig | -- | Sum type structure of GenericResult. |
70 | b74ebe44 | Klaus Aehlig | genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c |
71 | b74ebe44 | Klaus Aehlig | genericResult f _ (Bad a) = f a |
72 | b74ebe44 | Klaus Aehlig | genericResult _ g (Ok b) = g b |
73 | b74ebe44 | Klaus Aehlig | |
74 | 93be1ced | Iustin Pop | -- | Type alias for a string Result. |
75 | 93be1ced | Iustin Pop | type Result = GenericResult String |
76 | 93be1ced | Iustin Pop | |
77 | 93be1ced | Iustin Pop | -- | Type class for things that can be built from strings. |
78 | 93be1ced | Iustin Pop | class FromString a where |
79 | 93be1ced | Iustin Pop | mkFromString :: String -> a |
80 | 93be1ced | Iustin Pop | |
81 | 93be1ced | Iustin Pop | -- | Trivial 'String' instance; requires FlexibleInstances extension |
82 | 93be1ced | Iustin Pop | -- though. |
83 | 93be1ced | Iustin Pop | instance FromString [Char] where |
84 | 93be1ced | Iustin Pop | mkFromString = id |
85 | 93be1ced | Iustin Pop | |
86 | 93be1ced | Iustin Pop | -- | 'Monad' instance for 'GenericResult'. |
87 | 93be1ced | Iustin Pop | instance (FromString a) => Monad (GenericResult a) where |
88 | 0c37d1e4 | Iustin Pop | (>>=) (Bad x) _ = Bad x |
89 | 0c37d1e4 | Iustin Pop | (>>=) (Ok x) fn = fn x |
90 | 0c37d1e4 | Iustin Pop | return = Ok |
91 | 93be1ced | Iustin Pop | fail = Bad . mkFromString |
92 | 0c37d1e4 | Iustin Pop | |
93 | 93be1ced | Iustin Pop | instance Functor (GenericResult a) where |
94 | a9ccc950 | Iustin Pop | fmap _ (Bad msg) = Bad msg |
95 | a9ccc950 | Iustin Pop | fmap fn (Ok val) = Ok (fn val) |
96 | a9ccc950 | Iustin Pop | |
97 | 95e683c6 | Petr Pudlak | instance (FromString a, Monoid a) => MonadPlus (GenericResult a) where |
98 | 95e683c6 | Petr Pudlak | mzero = Bad $ mkFromString "zero Result when used as MonadPlus" |
99 | 0c37d1e4 | Iustin Pop | -- for mplus, when we 'add' two Bad values, we concatenate their |
100 | 0c37d1e4 | Iustin Pop | -- error descriptions |
101 | 95e683c6 | Petr Pudlak | (Bad x) `mplus` (Bad y) = Bad (x `mappend` mkFromString "; " `mappend` y) |
102 | 0c37d1e4 | Iustin Pop | (Bad _) `mplus` x = x |
103 | 0c37d1e4 | Iustin Pop | x@(Ok _) `mplus` _ = x |
104 | 0c37d1e4 | Iustin Pop | |
105 | 95e683c6 | Petr Pudlak | instance (FromString a) => MonadError a (GenericResult a) where |
106 | 95e683c6 | Petr Pudlak | throwError = Bad |
107 | 95e683c6 | Petr Pudlak | catchError x h = genericResult h (const x) x |
108 | 95e683c6 | Petr Pudlak | |
109 | 93be1ced | Iustin Pop | instance Applicative (GenericResult a) where |
110 | 25779212 | Iustin Pop | pure = Ok |
111 | 25779212 | Iustin Pop | (Bad f) <*> _ = Bad f |
112 | 25779212 | Iustin Pop | _ <*> (Bad x) = Bad x |
113 | 25779212 | Iustin Pop | (Ok f) <*> (Ok x) = Ok $ f x |
114 | 25779212 | Iustin Pop | |
115 | d71fbcc5 | Agata Murawska | -- | This is a monad transformation for Result. It's implementation is |
116 | d71fbcc5 | Agata Murawska | -- based on the implementations of MaybeT and ErrorT. |
117 | 93be1ced | Iustin Pop | newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)} |
118 | d71fbcc5 | Agata Murawska | |
119 | 95e683c6 | Petr Pudlak | -- | Eliminates a 'ResultT' value given appropriate continuations |
120 | 95e683c6 | Petr Pudlak | elimResultT :: (Monad m) |
121 | 95e683c6 | Petr Pudlak | => (a -> ResultT a' m b') |
122 | 95e683c6 | Petr Pudlak | -> (b -> ResultT a' m b') |
123 | 95e683c6 | Petr Pudlak | -> ResultT a m b |
124 | 95e683c6 | Petr Pudlak | -> ResultT a' m b' |
125 | 95e683c6 | Petr Pudlak | elimResultT l r = ResultT . (runResultT . result <=< runResultT) |
126 | 95e683c6 | Petr Pudlak | where |
127 | 95e683c6 | Petr Pudlak | result (Ok x) = r x |
128 | 95e683c6 | Petr Pudlak | result (Bad e) = l e |
129 | 95e683c6 | Petr Pudlak | {-# INLINE elimResultT #-} |
130 | 95e683c6 | Petr Pudlak | |
131 | 95e683c6 | Petr Pudlak | instance (Monad f) => Functor (ResultT a f) where |
132 | 95e683c6 | Petr Pudlak | fmap f = ResultT . liftM (fmap f) . runResultT |
133 | 95e683c6 | Petr Pudlak | |
134 | 95e683c6 | Petr Pudlak | instance (Monad m, FromString a) => Applicative (ResultT a m) where |
135 | 95e683c6 | Petr Pudlak | pure = return |
136 | 95e683c6 | Petr Pudlak | (<*>) = ap |
137 | 95e683c6 | Petr Pudlak | |
138 | 93be1ced | Iustin Pop | instance (Monad m, FromString a) => Monad (ResultT a m) where |
139 | 93be1ced | Iustin Pop | fail err = ResultT (return . Bad $ mkFromString err) |
140 | 274366e5 | Agata Murawska | return = lift . return |
141 | 95e683c6 | Petr Pudlak | (>>=) = flip (elimResultT throwError) |
142 | 95e683c6 | Petr Pudlak | |
143 | 95e683c6 | Petr Pudlak | instance (Monad m, FromString a) => MonadError a (ResultT a m) where |
144 | 95e683c6 | Petr Pudlak | throwError = resultT . Bad |
145 | 95e683c6 | Petr Pudlak | catchError x h = elimResultT h return x |
146 | d71fbcc5 | Agata Murawska | |
147 | 93be1ced | Iustin Pop | instance MonadTrans (ResultT a) where |
148 | 95e683c6 | Petr Pudlak | lift = ResultT . liftM Ok |
149 | d71fbcc5 | Agata Murawska | |
150 | 93be1ced | Iustin Pop | instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where |
151 | d71fbcc5 | Agata Murawska | liftIO = lift . liftIO |
152 | d71fbcc5 | Agata Murawska | |
153 | 95e683c6 | Petr Pudlak | instance (Monad m, FromString a, Monoid a) => MonadPlus (ResultT a m) where |
154 | 95e683c6 | Petr Pudlak | mzero = ResultT $ return mzero |
155 | 95e683c6 | Petr Pudlak | -- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit |
156 | 95e683c6 | Petr Pudlak | -- more complicated than 'mplus' of 'GenericResult'. |
157 | 95e683c6 | Petr Pudlak | mplus x y = elimResultT combine return x |
158 | 95e683c6 | Petr Pudlak | where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y) |
159 | 95e683c6 | Petr Pudlak | |
160 | d71fbcc5 | Agata Murawska | -- | Lift a `Result` value to a `ResultT`. |
161 | 93be1ced | Iustin Pop | resultT :: Monad m => GenericResult a b -> ResultT a m b |
162 | d71fbcc5 | Agata Murawska | resultT = ResultT . return |
163 | d71fbcc5 | Agata Murawska | |
164 | 93be1ced | Iustin Pop | -- | Simple checker for whether a 'GenericResult' is OK. |
165 | 93be1ced | Iustin Pop | isOk :: GenericResult a b -> Bool |
166 | 0c37d1e4 | Iustin Pop | isOk (Ok _) = True |
167 | 93be1ced | Iustin Pop | isOk _ = False |
168 | 0c37d1e4 | Iustin Pop | |
169 | 93be1ced | Iustin Pop | -- | Simple checker for whether a 'GenericResult' is a failure. |
170 | 93be1ced | Iustin Pop | isBad :: GenericResult a b -> Bool |
171 | 0c37d1e4 | Iustin Pop | isBad = not . isOk |
172 | 0c37d1e4 | Iustin Pop | |
173 | 9491766c | Hrvoje Ribicic | -- | Simple filter returning only OK values of GenericResult |
174 | 9491766c | Hrvoje Ribicic | justOk :: [GenericResult a b] -> [b] |
175 | ea128e20 | Klaus Aehlig | justOk = mapMaybe (genericResult (const Nothing) Just) |
176 | ea128e20 | Klaus Aehlig | |
177 | ea128e20 | Klaus Aehlig | -- | Simple filter returning only Bad values of GenericResult |
178 | ea128e20 | Klaus Aehlig | justBad :: [GenericResult a b] -> [a] |
179 | ea128e20 | Klaus Aehlig | justBad = mapMaybe (genericResult Just (const Nothing)) |
180 | 9491766c | Hrvoje Ribicic | |
181 | 98508e7f | Dato Simó | -- | Converter from Either to 'GenericResult'. |
182 | 93be1ced | Iustin Pop | eitherToResult :: Either a b -> GenericResult a b |
183 | 93be1ced | Iustin Pop | eitherToResult (Left s) = Bad s |
184 | 93be1ced | Iustin Pop | eitherToResult (Right v) = Ok v |
185 | f3f76ccc | Iustin Pop | |
186 | f3f76ccc | Iustin Pop | -- | Annotate a Result with an ownership information. |
187 | f3f76ccc | Iustin Pop | annotateResult :: String -> Result a -> Result a |
188 | f3f76ccc | Iustin Pop | annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s |
189 | f3f76ccc | Iustin Pop | annotateResult _ v = v |
190 | 1091021c | Iustin Pop | |
191 | b1c772fd | Klaus Aehlig | -- | Iterate while Ok. |
192 | b1c772fd | Klaus Aehlig | iterateOk :: (a -> GenericResult b a) -> a -> [a] |
193 | b1c772fd | Klaus Aehlig | iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a) |
194 | b1c772fd | Klaus Aehlig | |
195 | 2fc5653f | Iustin Pop | -- * Misc functionality |
196 | 2fc5653f | Iustin Pop | |
197 | 2fc5653f | Iustin Pop | -- | Return the first result with a True condition, or the default otherwise. |
198 | 2fc5653f | Iustin Pop | select :: a -- ^ default result |
199 | 2fc5653f | Iustin Pop | -> [(Bool, a)] -- ^ list of \"condition, result\" |
200 | 2fc5653f | Iustin Pop | -> a -- ^ first result which has a True condition, or default |
201 | 2fc5653f | Iustin Pop | select def = maybe def snd . find fst |
202 | 2fc5653f | Iustin Pop | |
203 | 2fc5653f | Iustin Pop | -- * Lookup of partial names functionality |
204 | 2fc5653f | Iustin Pop | |
205 | 2fc5653f | Iustin Pop | -- | The priority of a match in a lookup result. |
206 | 2fc5653f | Iustin Pop | data MatchPriority = ExactMatch |
207 | 2fc5653f | Iustin Pop | | MultipleMatch |
208 | 2fc5653f | Iustin Pop | | PartialMatch |
209 | 2fc5653f | Iustin Pop | | FailMatch |
210 | 139c0683 | Iustin Pop | deriving (Show, Enum, Eq, Ord) |
211 | 2fc5653f | Iustin Pop | |
212 | 2fc5653f | Iustin Pop | -- | The result of a name lookup in a list. |
213 | 2fc5653f | Iustin Pop | data LookupResult = LookupResult |
214 | 2fc5653f | Iustin Pop | { lrMatchPriority :: MatchPriority -- ^ The result type |
215 | 2fc5653f | Iustin Pop | -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise |
216 | 2fc5653f | Iustin Pop | , lrContent :: String |
217 | 139c0683 | Iustin Pop | } deriving (Show) |
218 | 2fc5653f | Iustin Pop | |
219 | 2fc5653f | Iustin Pop | -- | Lookup results have an absolute preference ordering. |
220 | 2fc5653f | Iustin Pop | instance Eq LookupResult where |
221 | 2fc5653f | Iustin Pop | (==) = (==) `on` lrMatchPriority |
222 | 2fc5653f | Iustin Pop | |
223 | 2fc5653f | Iustin Pop | instance Ord LookupResult where |
224 | 2fc5653f | Iustin Pop | compare = compare `on` lrMatchPriority |
225 | 2fc5653f | Iustin Pop | |
226 | 2fc5653f | Iustin Pop | -- | Check for prefix matches in names. |
227 | 2fc5653f | Iustin Pop | -- Implemented in Ganeti core utils.text.MatchNameComponent |
228 | 2fc5653f | Iustin Pop | -- as the regexp r"^%s(\..*)?$" % re.escape(key) |
229 | 2fc5653f | Iustin Pop | prefixMatch :: String -- ^ Lookup |
230 | 2fc5653f | Iustin Pop | -> String -- ^ Full name |
231 | 2fc5653f | Iustin Pop | -> Bool -- ^ Whether there is a prefix match |
232 | 2fc5653f | Iustin Pop | prefixMatch = isPrefixOf . (++ ".") |
233 | 2fc5653f | Iustin Pop | |
234 | 2fc5653f | Iustin Pop | -- | Is the lookup priority a "good" one? |
235 | 2fc5653f | Iustin Pop | goodMatchPriority :: MatchPriority -> Bool |
236 | 2fc5653f | Iustin Pop | goodMatchPriority ExactMatch = True |
237 | 2fc5653f | Iustin Pop | goodMatchPriority PartialMatch = True |
238 | 2fc5653f | Iustin Pop | goodMatchPriority _ = False |
239 | 2fc5653f | Iustin Pop | |
240 | 2fc5653f | Iustin Pop | -- | Is the lookup result an actual match? |
241 | 2fc5653f | Iustin Pop | goodLookupResult :: LookupResult -> Bool |
242 | 2fc5653f | Iustin Pop | goodLookupResult = goodMatchPriority . lrMatchPriority |
243 | 2fc5653f | Iustin Pop | |
244 | 2fc5653f | Iustin Pop | -- | Compares a canonical name and a lookup string. |
245 | 2fc5653f | Iustin Pop | compareNameComponent :: String -- ^ Canonical (target) name |
246 | 2fc5653f | Iustin Pop | -> String -- ^ Partial (lookup) name |
247 | 2fc5653f | Iustin Pop | -> LookupResult -- ^ Result of the lookup |
248 | 2fc5653f | Iustin Pop | compareNameComponent cnl lkp = |
249 | 2fc5653f | Iustin Pop | select (LookupResult FailMatch lkp) |
250 | 2fc5653f | Iustin Pop | [ (cnl == lkp , LookupResult ExactMatch cnl) |
251 | 2fc5653f | Iustin Pop | , (prefixMatch lkp cnl , LookupResult PartialMatch cnl) |
252 | 2fc5653f | Iustin Pop | ] |
253 | 2fc5653f | Iustin Pop | |
254 | 2fc5653f | Iustin Pop | -- | Lookup a string and choose the best result. |
255 | 2fc5653f | Iustin Pop | chooseLookupResult :: String -- ^ Lookup key |
256 | 2fc5653f | Iustin Pop | -> String -- ^ String to compare to the lookup key |
257 | 2fc5653f | Iustin Pop | -> LookupResult -- ^ Previous result |
258 | 2fc5653f | Iustin Pop | -> LookupResult -- ^ New result |
259 | 2fc5653f | Iustin Pop | chooseLookupResult lkp cstr old = |
260 | 2fc5653f | Iustin Pop | -- default: use class order to pick the minimum result |
261 | 2fc5653f | Iustin Pop | select (min new old) |
262 | 2fc5653f | Iustin Pop | -- special cases: |
263 | 2fc5653f | Iustin Pop | -- short circuit if the new result is an exact match |
264 | 2fc5653f | Iustin Pop | [ (lrMatchPriority new == ExactMatch, new) |
265 | 2fc5653f | Iustin Pop | -- if both are partial matches generate a multiple match |
266 | 2fc5653f | Iustin Pop | , (partial2, LookupResult MultipleMatch lkp) |
267 | 2fc5653f | Iustin Pop | ] where new = compareNameComponent cstr lkp |
268 | 2fc5653f | Iustin Pop | partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new] |
269 | 2fc5653f | Iustin Pop | |
270 | 2fc5653f | Iustin Pop | -- | Find the canonical name for a lookup string in a list of names. |
271 | 2fc5653f | Iustin Pop | lookupName :: [String] -- ^ List of keys |
272 | 2fc5653f | Iustin Pop | -> String -- ^ Lookup string |
273 | 2fc5653f | Iustin Pop | -> LookupResult -- ^ Result of the lookup |
274 | 2fc5653f | Iustin Pop | lookupName l s = foldr (chooseLookupResult s) |
275 | 2fc5653f | Iustin Pop | (LookupResult FailMatch s) l |
276 | 4651c69f | Jose A. Lopes | |
277 | 4651c69f | Jose A. Lopes | -- | Wrapper for a Haskell 'Set' |
278 | 4651c69f | Jose A. Lopes | -- |
279 | 4651c69f | Jose A. Lopes | -- This type wraps a 'Set' and it is used in the Haskell to Python |
280 | 4651c69f | Jose A. Lopes | -- opcode generation to transform a Haskell 'Set' into a Python 'list' |
281 | 4651c69f | Jose A. Lopes | -- without duplicate elements. |
282 | 4651c69f | Jose A. Lopes | newtype ListSet a = ListSet { unListSet :: Set a } |
283 | 4651c69f | Jose A. Lopes | deriving (Eq, Show) |
284 | 4651c69f | Jose A. Lopes | |
285 | 4651c69f | Jose A. Lopes | instance (Ord a, JSON a) => JSON (ListSet a) where |
286 | 4651c69f | Jose A. Lopes | showJSON = JSON.showJSON . unListSet |
287 | 4651c69f | Jose A. Lopes | readJSON = liftM ListSet . JSON.readJSON |
288 | 4651c69f | Jose A. Lopes | |
289 | 4651c69f | Jose A. Lopes | emptyListSet :: ListSet a |
290 | 4651c69f | Jose A. Lopes | emptyListSet = ListSet Set.empty |