root / src / Ganeti / BasicTypes.hs @ 0efada2a
History | View | Annotate | Download (14.3 kB)
1 |
{-# LANGUAGE FlexibleInstances #-} |
---|---|
2 |
{-# LANGUAGE FlexibleContexts #-} |
3 |
{-# LANGUAGE MultiParamTypeClasses #-} |
4 |
{-# LANGUAGE TypeFamilies #-} |
5 |
|
6 |
{- |
7 |
|
8 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
9 |
|
10 |
This program is free software; you can redistribute it and/or modify |
11 |
it under the terms of the GNU General Public License as published by |
12 |
the Free Software Foundation; either version 2 of the License, or |
13 |
(at your option) any later version. |
14 |
|
15 |
This program is distributed in the hope that it will be useful, but |
16 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
17 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
18 |
General Public License for more details. |
19 |
|
20 |
You should have received a copy of the GNU General Public License |
21 |
along with this program; if not, write to the Free Software |
22 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
23 |
02110-1301, USA. |
24 |
|
25 |
-} |
26 |
|
27 |
module Ganeti.BasicTypes |
28 |
( GenericResult(..) |
29 |
, genericResult |
30 |
, Result |
31 |
, ResultT(..) |
32 |
, mkResultT |
33 |
, withError |
34 |
, withErrorT |
35 |
, toError |
36 |
, toErrorBase |
37 |
, toErrorStr |
38 |
, Error(..) -- re-export from Control.Monad.Error |
39 |
, MonadIO(..) -- re-export from Control.Monad.IO.Class |
40 |
, isOk |
41 |
, isBad |
42 |
, justOk |
43 |
, justBad |
44 |
, eitherToResult |
45 |
, annotateResult |
46 |
, annotateError |
47 |
, failError |
48 |
, catchErrorT |
49 |
, handleErrorT |
50 |
, iterateOk |
51 |
, select |
52 |
, runListHead |
53 |
, LookupResult(..) |
54 |
, MatchPriority(..) |
55 |
, lookupName |
56 |
, goodLookupResult |
57 |
, goodMatchPriority |
58 |
, prefixMatch |
59 |
, compareNameComponent |
60 |
, ListSet(..) |
61 |
, emptyListSet |
62 |
) where |
63 |
|
64 |
import Control.Applicative |
65 |
import Control.Exception (try) |
66 |
import Control.Monad |
67 |
import Control.Monad.Base |
68 |
import Control.Monad.Error.Class |
69 |
import Control.Monad.Trans |
70 |
import Control.Monad.Trans.Control |
71 |
import Data.Function |
72 |
import Data.List |
73 |
import Data.Maybe |
74 |
import Data.Monoid |
75 |
import Data.Set (Set) |
76 |
import qualified Data.Set as Set (empty) |
77 |
import Text.JSON (JSON) |
78 |
import qualified Text.JSON as JSON (readJSON, showJSON) |
79 |
|
80 |
-- | Generic monad for our error handling mechanisms. |
81 |
data GenericResult a b |
82 |
= Bad a |
83 |
| Ok b |
84 |
deriving (Show, Eq) |
85 |
|
86 |
-- | Sum type structure of GenericResult. |
87 |
genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c |
88 |
genericResult f _ (Bad a) = f a |
89 |
genericResult _ g (Ok b) = g b |
90 |
{-# INLINE genericResult #-} |
91 |
|
92 |
-- | Type alias for a string Result. |
93 |
type Result = GenericResult String |
94 |
|
95 |
-- | 'Monad' instance for 'GenericResult'. |
96 |
instance (Error a) => Monad (GenericResult a) where |
97 |
(>>=) (Bad x) _ = Bad x |
98 |
(>>=) (Ok x) fn = fn x |
99 |
return = Ok |
100 |
fail = Bad . strMsg |
101 |
|
102 |
instance Functor (GenericResult a) where |
103 |
fmap _ (Bad msg) = Bad msg |
104 |
fmap fn (Ok val) = Ok (fn val) |
105 |
|
106 |
instance (Error a, Monoid a) => MonadPlus (GenericResult a) where |
107 |
mzero = Bad $ strMsg "zero Result when used as MonadPlus" |
108 |
-- for mplus, when we 'add' two Bad values, we concatenate their |
109 |
-- error descriptions |
110 |
(Bad x) `mplus` (Bad y) = Bad (x `mappend` strMsg "; " `mappend` y) |
111 |
(Bad _) `mplus` x = x |
112 |
x@(Ok _) `mplus` _ = x |
113 |
|
114 |
instance (Error a) => MonadError a (GenericResult a) where |
115 |
throwError = Bad |
116 |
{-# INLINE throwError #-} |
117 |
catchError x h = genericResult h (const x) x |
118 |
{-# INLINE catchError #-} |
119 |
|
120 |
instance Applicative (GenericResult a) where |
121 |
pure = Ok |
122 |
(Bad f) <*> _ = Bad f |
123 |
_ <*> (Bad x) = Bad x |
124 |
(Ok f) <*> (Ok x) = Ok $ f x |
125 |
|
126 |
instance (Error a, Monoid a) => Alternative (GenericResult a) where |
127 |
empty = mzero |
128 |
(<|>) = mplus |
129 |
|
130 |
-- | This is a monad transformation for Result. It's implementation is |
131 |
-- based on the implementations of MaybeT and ErrorT. |
132 |
-- |
133 |
-- 'ResultT' is very similar to @ErrorT@, but with one subtle difference: |
134 |
-- If 'mplus' combines two failing operations, errors of both of them |
135 |
-- are combined. |
136 |
newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)} |
137 |
|
138 |
-- | Eliminates a 'ResultT' value given appropriate continuations |
139 |
elimResultT :: (Monad m) |
140 |
=> (a -> ResultT a' m b') |
141 |
-> (b -> ResultT a' m b') |
142 |
-> ResultT a m b |
143 |
-> ResultT a' m b' |
144 |
elimResultT l r = ResultT . (runResultT . result <=< runResultT) |
145 |
where |
146 |
result (Ok x) = r x |
147 |
result (Bad e) = l e |
148 |
{-# INLINE elimResultT #-} |
149 |
|
150 |
instance (Monad f) => Functor (ResultT a f) where |
151 |
fmap f = ResultT . liftM (fmap f) . runResultT |
152 |
|
153 |
instance (Monad m, Error a) => Applicative (ResultT a m) where |
154 |
pure = return |
155 |
(<*>) = ap |
156 |
|
157 |
instance (Monad m, Error a) => Monad (ResultT a m) where |
158 |
fail err = ResultT (return . Bad $ strMsg err) |
159 |
return = lift . return |
160 |
(>>=) = flip (elimResultT throwError) |
161 |
|
162 |
instance (Monad m, Error a) => MonadError a (ResultT a m) where |
163 |
throwError = ResultT . return . Bad |
164 |
catchError = catchErrorT |
165 |
|
166 |
instance MonadTrans (ResultT a) where |
167 |
lift = ResultT . liftM Ok |
168 |
|
169 |
-- | The instance catches any 'IOError' using 'try' and converts it into an |
170 |
-- error message using 'strMsg'. |
171 |
-- |
172 |
-- This way, monadic code within 'ResultT' that uses solely 'liftIO' to |
173 |
-- include 'IO' actions ensures that all IO exceptions are handled. |
174 |
-- |
175 |
-- Other exceptions (see instances of 'Exception') are not currently handled. |
176 |
-- This might be revised in the future. |
177 |
instance (MonadIO m, Error a) => MonadIO (ResultT a m) where |
178 |
liftIO = ResultT . liftIO |
179 |
. liftM (either (failError . show) return) |
180 |
. (try :: IO a -> IO (Either IOError a)) |
181 |
|
182 |
instance (MonadBase IO m, Error a) => MonadBase IO (ResultT a m) where |
183 |
liftBase = ResultT . liftBase |
184 |
. liftM (either (failError . show) return) |
185 |
. (try :: IO a -> IO (Either IOError a)) |
186 |
|
187 |
instance (Error a) => MonadTransControl (ResultT a) where |
188 |
newtype StT (ResultT a) b = StResultT { runStResultT :: GenericResult a b } |
189 |
liftWith f = ResultT . liftM return $ f (liftM StResultT . runResultT) |
190 |
restoreT = ResultT . liftM runStResultT |
191 |
{-# INLINE liftWith #-} |
192 |
{-# INLINE restoreT #-} |
193 |
|
194 |
instance (Error a, MonadBaseControl IO m) |
195 |
=> MonadBaseControl IO (ResultT a m) where |
196 |
newtype StM (ResultT a m) b |
197 |
= StMResultT { runStMResultT :: ComposeSt (ResultT a) m b } |
198 |
liftBaseWith = defaultLiftBaseWith StMResultT |
199 |
restoreM = defaultRestoreM runStMResultT |
200 |
{-# INLINE liftBaseWith #-} |
201 |
{-# INLINE restoreM #-} |
202 |
|
203 |
instance (Monad m, Error a, Monoid a) => MonadPlus (ResultT a m) where |
204 |
mzero = ResultT $ return mzero |
205 |
-- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit |
206 |
-- more complicated than 'mplus' of 'GenericResult'. |
207 |
mplus x y = elimResultT combine return x |
208 |
where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y) |
209 |
|
210 |
instance (Monad m, Error a, Monoid a) => Alternative (ResultT a m) where |
211 |
empty = mzero |
212 |
(<|>) = mplus |
213 |
|
214 |
-- | Changes the error message of a result value, if present. |
215 |
-- Note that since 'GenericResult' is also a 'MonadError', this function |
216 |
-- is a generalization of |
217 |
-- @(Error e') => (e' -> e) -> GenericResult e' a -> GenericResult e a@ |
218 |
withError :: (MonadError e m) => (e' -> e) -> GenericResult e' a -> m a |
219 |
withError f = genericResult (throwError . f) return |
220 |
|
221 |
-- | Changes the error message of a @ResultT@ value, if present. |
222 |
withErrorT :: (Monad m, Error e) |
223 |
=> (e' -> e) -> ResultT e' m a -> ResultT e m a |
224 |
withErrorT f = ResultT . liftM (withError f) . runResultT |
225 |
|
226 |
-- | Lift a 'Result' value to any 'MonadError'. Since 'ResultT' is itself its |
227 |
-- instance, it's a generalization of |
228 |
-- @Monad m => GenericResult a b -> ResultT a m b@. |
229 |
toError :: (MonadError e m) => GenericResult e a -> m a |
230 |
toError = genericResult throwError return |
231 |
{-# INLINE toError #-} |
232 |
|
233 |
-- | Lift a 'ResultT' value into any 'MonadError' with the same base monad. |
234 |
toErrorBase :: (MonadBase b m, MonadError e m) => ResultT e b a -> m a |
235 |
toErrorBase = (toError =<<) . liftBase . runResultT |
236 |
{-# INLINE toErrorBase #-} |
237 |
|
238 |
-- | An alias for @withError strMsg@, which is often used to lift a pure error |
239 |
-- to a monad stack. See also 'annotateResult'. |
240 |
toErrorStr :: (MonadError e m, Error e) => Result a -> m a |
241 |
toErrorStr = withError strMsg |
242 |
|
243 |
-- | Converts a monadic result with a 'String' message into |
244 |
-- a 'ResultT' with an arbitrary 'Error'. |
245 |
-- |
246 |
-- Expects that the given action has already taken care of any possible |
247 |
-- errors. In particular, if applied on @IO (Result a)@, any exceptions |
248 |
-- should be handled by the given action. |
249 |
-- |
250 |
-- See also 'toErrorStr'. |
251 |
mkResultT :: (Monad m, Error e) => m (Result a) -> ResultT e m a |
252 |
mkResultT = ResultT . liftM toErrorStr |
253 |
|
254 |
-- | Simple checker for whether a 'GenericResult' is OK. |
255 |
isOk :: GenericResult a b -> Bool |
256 |
isOk (Ok _) = True |
257 |
isOk _ = False |
258 |
|
259 |
-- | Simple checker for whether a 'GenericResult' is a failure. |
260 |
isBad :: GenericResult a b -> Bool |
261 |
isBad = not . isOk |
262 |
|
263 |
-- | Simple filter returning only OK values of GenericResult |
264 |
justOk :: [GenericResult a b] -> [b] |
265 |
justOk = mapMaybe (genericResult (const Nothing) Just) |
266 |
|
267 |
-- | Simple filter returning only Bad values of GenericResult |
268 |
justBad :: [GenericResult a b] -> [a] |
269 |
justBad = mapMaybe (genericResult Just (const Nothing)) |
270 |
|
271 |
-- | Converter from Either to 'GenericResult'. |
272 |
eitherToResult :: Either a b -> GenericResult a b |
273 |
eitherToResult (Left s) = Bad s |
274 |
eitherToResult (Right v) = Ok v |
275 |
|
276 |
-- | Annotate an error with an ownership information, lifting it to a |
277 |
-- 'MonadError'. Since 'Result' is an instance of 'MonadError' itself, |
278 |
-- it's a generalization of type @String -> Result a -> Result a@. |
279 |
-- See also 'toErrorStr'. |
280 |
annotateResult :: (MonadError e m, Error e) => String -> Result a -> m a |
281 |
annotateResult owner = toErrorStr . annotateError owner |
282 |
|
283 |
-- | Annotate an error with an ownership information inside a 'MonadError'. |
284 |
-- See also 'annotateResult'. |
285 |
annotateError :: (MonadError e m, Error e, Monoid e) => String -> m a -> m a |
286 |
annotateError owner = |
287 |
flip catchError (throwError . mappend (strMsg $ owner ++ ": ")) |
288 |
{-# INLINE annotateError #-} |
289 |
|
290 |
-- | Throws a 'String' message as an error in a 'MonadError'. |
291 |
-- This is a generalization of 'Bad'. |
292 |
-- It's similar to 'fail', but works within a 'MonadError', avoiding the |
293 |
-- unsafe nature of 'fail'. |
294 |
failError :: (MonadError e m, Error e) => String -> m a |
295 |
failError = throwError . strMsg |
296 |
|
297 |
-- | A synonym for @flip@ 'catchErrorT'. |
298 |
handleErrorT :: (Monad m, Error e) |
299 |
=> (e' -> ResultT e m a) -> ResultT e' m a -> ResultT e m a |
300 |
handleErrorT handler = elimResultT handler return |
301 |
{-# INLINE handleErrorT #-} |
302 |
|
303 |
-- | Catches an error in a @ResultT@ value. This is similar to 'catchError', |
304 |
-- but in addition allows to change the error type. |
305 |
catchErrorT :: (Monad m, Error e) |
306 |
=> ResultT e' m a -> (e' -> ResultT e m a) -> ResultT e m a |
307 |
catchErrorT = flip handleErrorT |
308 |
{-# INLINE catchErrorT #-} |
309 |
|
310 |
-- | Iterate while Ok. |
311 |
iterateOk :: (a -> GenericResult b a) -> a -> [a] |
312 |
iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a) |
313 |
|
314 |
-- * Misc functionality |
315 |
|
316 |
-- | Return the first result with a True condition, or the default otherwise. |
317 |
select :: a -- ^ default result |
318 |
-> [(Bool, a)] -- ^ list of \"condition, result\" |
319 |
-> a -- ^ first result which has a True condition, or default |
320 |
select def = maybe def snd . find fst |
321 |
|
322 |
-- | Apply a function to the first element of a list, return the default |
323 |
-- value, if the list is empty. This is just a convenient combination of |
324 |
-- maybe and listToMaybe. |
325 |
runListHead :: a -> (b -> a) -> [b] -> a |
326 |
runListHead a f = maybe a f . listToMaybe |
327 |
|
328 |
-- * Lookup of partial names functionality |
329 |
|
330 |
-- | The priority of a match in a lookup result. |
331 |
data MatchPriority = ExactMatch |
332 |
| MultipleMatch |
333 |
| PartialMatch |
334 |
| FailMatch |
335 |
deriving (Show, Enum, Eq, Ord) |
336 |
|
337 |
-- | The result of a name lookup in a list. |
338 |
data LookupResult = LookupResult |
339 |
{ lrMatchPriority :: MatchPriority -- ^ The result type |
340 |
-- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise |
341 |
, lrContent :: String |
342 |
} deriving (Show) |
343 |
|
344 |
-- | Lookup results have an absolute preference ordering. |
345 |
instance Eq LookupResult where |
346 |
(==) = (==) `on` lrMatchPriority |
347 |
|
348 |
instance Ord LookupResult where |
349 |
compare = compare `on` lrMatchPriority |
350 |
|
351 |
-- | Check for prefix matches in names. |
352 |
-- Implemented in Ganeti core utils.text.MatchNameComponent |
353 |
-- as the regexp r"^%s(\..*)?$" % re.escape(key) |
354 |
prefixMatch :: String -- ^ Lookup |
355 |
-> String -- ^ Full name |
356 |
-> Bool -- ^ Whether there is a prefix match |
357 |
prefixMatch = isPrefixOf . (++ ".") |
358 |
|
359 |
-- | Is the lookup priority a "good" one? |
360 |
goodMatchPriority :: MatchPriority -> Bool |
361 |
goodMatchPriority ExactMatch = True |
362 |
goodMatchPriority PartialMatch = True |
363 |
goodMatchPriority _ = False |
364 |
|
365 |
-- | Is the lookup result an actual match? |
366 |
goodLookupResult :: LookupResult -> Bool |
367 |
goodLookupResult = goodMatchPriority . lrMatchPriority |
368 |
|
369 |
-- | Compares a canonical name and a lookup string. |
370 |
compareNameComponent :: String -- ^ Canonical (target) name |
371 |
-> String -- ^ Partial (lookup) name |
372 |
-> LookupResult -- ^ Result of the lookup |
373 |
compareNameComponent cnl lkp = |
374 |
select (LookupResult FailMatch lkp) |
375 |
[ (cnl == lkp , LookupResult ExactMatch cnl) |
376 |
, (prefixMatch lkp cnl , LookupResult PartialMatch cnl) |
377 |
] |
378 |
|
379 |
-- | Lookup a string and choose the best result. |
380 |
chooseLookupResult :: String -- ^ Lookup key |
381 |
-> String -- ^ String to compare to the lookup key |
382 |
-> LookupResult -- ^ Previous result |
383 |
-> LookupResult -- ^ New result |
384 |
chooseLookupResult lkp cstr old = |
385 |
-- default: use class order to pick the minimum result |
386 |
select (min new old) |
387 |
-- special cases: |
388 |
-- short circuit if the new result is an exact match |
389 |
[ (lrMatchPriority new == ExactMatch, new) |
390 |
-- if both are partial matches generate a multiple match |
391 |
, (partial2, LookupResult MultipleMatch lkp) |
392 |
] where new = compareNameComponent cstr lkp |
393 |
partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new] |
394 |
|
395 |
-- | Find the canonical name for a lookup string in a list of names. |
396 |
lookupName :: [String] -- ^ List of keys |
397 |
-> String -- ^ Lookup string |
398 |
-> LookupResult -- ^ Result of the lookup |
399 |
lookupName l s = foldr (chooseLookupResult s) |
400 |
(LookupResult FailMatch s) l |
401 |
|
402 |
-- | Wrapper for a Haskell 'Set' |
403 |
-- |
404 |
-- This type wraps a 'Set' and it is used in the Haskell to Python |
405 |
-- opcode generation to transform a Haskell 'Set' into a Python 'list' |
406 |
-- without duplicate elements. |
407 |
newtype ListSet a = ListSet { unListSet :: Set a } |
408 |
deriving (Eq, Show) |
409 |
|
410 |
instance (Ord a, JSON a) => JSON (ListSet a) where |
411 |
showJSON = JSON.showJSON . unListSet |
412 |
readJSON = liftM ListSet . JSON.readJSON |
413 |
|
414 |
emptyListSet :: ListSet a |
415 |
emptyListSet = ListSet Set.empty |