BasicTypes.hs 12.7 KB
Newer Older
1
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
Iustin Pop's avatar
Iustin Pop committed
2

3
4
{-

Iustin Pop's avatar
Iustin Pop committed
5
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
Klaus Aehlig's avatar
Klaus Aehlig committed
6
All rights reserved.
7

Klaus Aehlig's avatar
Klaus Aehlig committed
8
9
10
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
11

Klaus Aehlig's avatar
Klaus Aehlig committed
12
13
1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
14

Klaus Aehlig's avatar
Klaus Aehlig committed
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
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.
30
31
32
33

-}

module Ganeti.BasicTypes
Iustin Pop's avatar
Iustin Pop committed
34
  ( GenericResult(..)
35
  , genericResult
Iustin Pop's avatar
Iustin Pop committed
36
  , Result
37
  , ResultT(..)
38
39
40
  , mkResultT
  , withError
  , withErrorT
41
  , resultT
42
  , toErrorStr
43
  , Error(..) -- re-export from Control.Monad.Error
44
45
  , isOk
  , isBad
46
  , justOk
47
  , justBad
48
  , eitherToResult
Iustin Pop's avatar
Iustin Pop committed
49
  , annotateResult
50
51
52
53
  , annotateError
  , failError
  , catchErrorT
  , handleErrorT
54
  , iterateOk
Iustin Pop's avatar
Iustin Pop committed
55
  , select
56
  , runListHead
Iustin Pop's avatar
Iustin Pop committed
57
58
59
60
61
62
63
  , LookupResult(..)
  , MatchPriority(..)
  , lookupName
  , goodLookupResult
  , goodMatchPriority
  , prefixMatch
  , compareNameComponent
64
65
  , ListSet(..)
  , emptyListSet
66
67
  ) where

68
import Control.Applicative
69
import Control.Monad
70
import Control.Monad.Error.Class
71
import Control.Monad.Trans
Iustin Pop's avatar
Iustin Pop committed
72
73
import Data.Function
import Data.List
74
import Data.Maybe
75
import Data.Monoid
76
77
78
79
import Data.Set (Set)
import qualified Data.Set as Set (empty)
import Text.JSON (JSON)
import qualified Text.JSON as JSON (readJSON, showJSON)
80

Iustin Pop's avatar
Iustin Pop committed
81
82
83
84
-- | Generic monad for our error handling mechanisms.
data GenericResult a b
  = Bad a
  | Ok b
85
    deriving (Show, Eq)
86

87
88
89
90
-- | 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
91
{-# INLINE genericResult #-}
92

Iustin Pop's avatar
Iustin Pop committed
93
94
95
96
-- | Type alias for a string Result.
type Result = GenericResult String

-- | 'Monad' instance for 'GenericResult'.
97
instance (Error a) => Monad (GenericResult a) where
98
99
100
  (>>=) (Bad x) _ = Bad x
  (>>=) (Ok x) fn = fn x
  return = Ok
101
  fail   = Bad . strMsg
102

Iustin Pop's avatar
Iustin Pop committed
103
instance Functor (GenericResult a) where
104
105
106
  fmap _ (Bad msg) = Bad msg
  fmap fn (Ok val) = Ok (fn val)

107
108
instance (Error a, Monoid a) => MonadPlus (GenericResult a) where
  mzero = Bad $ strMsg "zero Result when used as MonadPlus"
109
110
  -- for mplus, when we 'add' two Bad values, we concatenate their
  -- error descriptions
111
  (Bad x) `mplus` (Bad y) = Bad (x `mappend` strMsg "; " `mappend` y)
112
113
114
  (Bad _) `mplus` x = x
  x@(Ok _) `mplus` _ = x

115
instance (Error a) => MonadError a (GenericResult a) where
116
  throwError = Bad
117
  {-# INLINE throwError #-}
118
  catchError x h = genericResult h (const x) x
119
  {-# INLINE catchError #-}
120

Iustin Pop's avatar
Iustin Pop committed
121
instance Applicative (GenericResult a) where
122
123
124
125
126
  pure = Ok
  (Bad f) <*> _       = Bad f
  _       <*> (Bad x) = Bad x
  (Ok f)  <*> (Ok x)  = Ok $ f x

127
instance (Error a, Monoid a) => Alternative (GenericResult a) where
128
129
130
  empty = mzero
  (<|>) = mplus

131
132
-- | This is a monad transformation for Result. It's implementation is
-- based on the implementations of MaybeT and ErrorT.
133
134
135
136
--
-- 'ResultT' is very similar to @ErrorT@, but with one subtle difference:
-- If 'mplus' combines two failing operations, errors of both of them
-- are combined.
Iustin Pop's avatar
Iustin Pop committed
137
newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}
138

139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
-- | Eliminates a 'ResultT' value given appropriate continuations
elimResultT :: (Monad m)
            => (a -> ResultT a' m b')
            -> (b -> ResultT a' m b')
            -> ResultT a m b
            -> ResultT a' m b'
elimResultT l r = ResultT . (runResultT . result <=< runResultT)
  where
    result (Ok x)   = r x
    result (Bad e)  = l e
{-# INLINE elimResultT #-}

instance (Monad f) => Functor (ResultT a f) where
  fmap f = ResultT . liftM (fmap f) . runResultT

154
instance (Monad m, Error a) => Applicative (ResultT a m) where
155
156
157
  pure = return
  (<*>) = ap

158
159
instance (Monad m, Error a) => Monad (ResultT a m) where
  fail err = ResultT (return . Bad $ strMsg err)
160
  return   = lift . return
161
162
  (>>=)    = flip (elimResultT throwError)

163
instance (Monad m, Error a) => MonadError a (ResultT a m) where
164
  throwError = resultT . Bad
165
  catchError = catchErrorT
166

Iustin Pop's avatar
Iustin Pop committed
167
instance MonadTrans (ResultT a) where
168
  lift = ResultT . liftM Ok
169

170
instance (MonadIO m, Error a) => MonadIO (ResultT a m) where
171
172
  liftIO = lift . liftIO

173
instance (Monad m, Error a, Monoid a) => MonadPlus (ResultT a m) where
174
175
176
177
178
179
  mzero = ResultT $ return mzero
  -- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit
  -- more complicated than 'mplus' of 'GenericResult'.
  mplus x y = elimResultT combine return x
    where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y)

180
instance (Monad m, Error a, Monoid a) => Alternative (ResultT a m) where
181
182
183
  empty = mzero
  (<|>) = mplus

184
185
186
187
188
189
190
191
192
193
194
195
-- | Changes the error message of a result value, if present.
-- Note that since 'GenericResult' is also a 'MonadError', this function
-- is a generalization of
-- @(Error e') => (e' -> e) -> GenericResult e' a -> GenericResult e a@
withError :: (MonadError e m) => (e' -> e) -> GenericResult e' a -> m a
withError f = genericResult (throwError . f) return

-- | Changes the error message of a @ResultT@ value, if present.
withErrorT :: (Monad m, Error e)
           => (e' -> e) -> ResultT e' m a -> ResultT e m a
withErrorT f = ResultT . liftM (withError f) . runResultT

196
-- | Lift a `Result` value to a `ResultT`.
Iustin Pop's avatar
Iustin Pop committed
197
resultT :: Monad m => GenericResult a b -> ResultT a m b
198
199
resultT = ResultT . return

200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
-- | An alias for @withError strMsg@, which is often used to lift a pure error
-- to a monad stack. See also 'annotateResult'.
toErrorStr :: (MonadError e m, Error e) => Result a -> m a
toErrorStr = withError strMsg

-- | Converts a monadic result with a 'String' message into
-- a 'ResultT' with an arbitrary 'Error'.
--
-- Expects that the given action has already taken care of any possible
-- errors. In particular, if applied on @IO (Result a)@, any exceptions
-- should be handled by the given action.
--
-- See also 'toErrorStr'.
mkResultT :: (Monad m, Error e) => m (Result a) -> ResultT e m a
mkResultT = ResultT . liftM toErrorStr

Iustin Pop's avatar
Iustin Pop committed
216
217
-- | Simple checker for whether a 'GenericResult' is OK.
isOk :: GenericResult a b -> Bool
218
isOk (Ok _) = True
Iustin Pop's avatar
Iustin Pop committed
219
isOk _      = False
220

Iustin Pop's avatar
Iustin Pop committed
221
222
-- | Simple checker for whether a 'GenericResult' is a failure.
isBad :: GenericResult a b -> Bool
223
224
isBad = not . isOk

225
226
-- | Simple filter returning only OK values of GenericResult
justOk :: [GenericResult a b] -> [b]
227
228
229
230
231
justOk = mapMaybe (genericResult (const Nothing) Just)

-- | Simple filter returning only Bad values of GenericResult
justBad :: [GenericResult a b] -> [a]
justBad = mapMaybe (genericResult Just (const Nothing))
232

233
-- | Converter from Either to 'GenericResult'.
Iustin Pop's avatar
Iustin Pop committed
234
235
236
eitherToResult :: Either a b -> GenericResult a b
eitherToResult (Left  s) = Bad s
eitherToResult (Right v) = Ok  v
Iustin Pop's avatar
Iustin Pop committed
237

238
--- | Annotate a Result with an ownership information.
Iustin Pop's avatar
Iustin Pop committed
239
240
241
annotateResult :: String -> Result a -> Result a
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
annotateResult _ v = v
Iustin Pop's avatar
Iustin Pop committed
242

243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
-- | Annotate an error with an ownership information inside a 'MonadError'.
-- See also 'annotateResult'.
annotateError :: (MonadError e m, Error e, Monoid e) => String -> m a -> m a
annotateError owner =
  flip catchError (throwError . mappend (strMsg $ owner ++ ": "))
{-# INLINE annotateError #-}

-- | Throws a 'String' message as an error in a 'MonadError'.
-- This is a generalization of 'Bad'.
-- It's similar to 'fail', but works within a 'MonadError', avoiding the
-- unsafe nature of 'fail'.
failError :: (MonadError e m, Error e) => String -> m a
failError = throwError . strMsg

-- | A synonym for @flip@ 'catchErrorT'.
handleErrorT :: (Monad m, Error e)
             => (e' -> ResultT e m a) -> ResultT e' m a -> ResultT e m a
handleErrorT handler = elimResultT handler return
{-# INLINE handleErrorT #-}

-- | Catches an error in a @ResultT@ value. This is similar to 'catchError',
-- but in addition allows to change the error type.
catchErrorT :: (Monad m, Error e)
            => ResultT e' m a -> (e' -> ResultT e m a) -> ResultT e m a
catchErrorT = flip handleErrorT
{-# INLINE catchErrorT #-}

270
271
272
273
-- | Iterate while Ok.
iterateOk :: (a -> GenericResult b a) -> a -> [a]
iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a)

Iustin Pop's avatar
Iustin Pop committed
274
275
276
277
278
279
280
281
-- * 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

282
283
284
285
286
287
-- | 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

Iustin Pop's avatar
Iustin Pop committed
288
289
290
291
292
293
294
-- * Lookup of partial names functionality

-- | The priority of a match in a lookup result.
data MatchPriority = ExactMatch
                   | MultipleMatch
                   | PartialMatch
                   | FailMatch
295
                   deriving (Show, Enum, Eq, Ord)
Iustin Pop's avatar
Iustin Pop committed
296
297
298
299
300
301

-- | 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
302
  } deriving (Show)
Iustin Pop's avatar
Iustin Pop committed
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360

-- | 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
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375

-- | 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