BasicTypes.hs 14.5 KB
Newer Older
1
2
3
4
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
Iustin Pop's avatar
Iustin Pop committed
5

6
7
{-

Iustin Pop's avatar
Iustin Pop committed
8
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

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

65
import Control.Applicative
66
import Control.Exception (try)
67
import Control.Monad
68
import Control.Monad.Base
69
import Control.Monad.Error.Class
70
import Control.Monad.Trans
71
import Control.Monad.Trans.Control
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 . return . 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
171
172
173
174
175
176
177
-- | The instance catches any 'IOError' using 'try' and converts it into an
-- error message using 'strMsg'.
--
-- This way, monadic code within 'ResultT' that uses solely 'liftIO' to
-- include 'IO' actions ensures that all IO exceptions are handled.
--
-- Other exceptions (see instances of 'Exception') are not currently handled.
-- This might be revised in the future.
178
instance (MonadIO m, Error a) => MonadIO (ResultT a m) where
179
180
181
  liftIO = ResultT . liftIO
                   . liftM (either (failError . show) return)
                   . (try :: IO a -> IO (Either IOError a))
182

183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
instance (MonadBase IO m, Error a) => MonadBase IO (ResultT a m) where
  liftBase = ResultT . liftBase
                   . liftM (either (failError . show) return)
                   . (try :: IO a -> IO (Either IOError a))

instance (Error a) => MonadTransControl (ResultT a) where
  newtype StT (ResultT a) b = StResultT { runStResultT :: GenericResult a b }
  liftWith f = ResultT . liftM return $ f (liftM StResultT . runResultT)
  restoreT = ResultT . liftM runStResultT
  {-# INLINE liftWith #-}
  {-# INLINE restoreT #-}

instance (Error a, MonadBaseControl IO m)
         => MonadBaseControl IO (ResultT a m) where
  newtype StM (ResultT a m) b
    = StMResultT { runStMResultT :: ComposeSt (ResultT a) m b }
  liftBaseWith = defaultLiftBaseWith StMResultT
  restoreM = defaultRestoreM runStMResultT
  {-# INLINE liftBaseWith #-}
  {-# INLINE restoreM #-}

204
instance (Monad m, Error a, Monoid a) => MonadPlus (ResultT a m) where
205
206
207
208
209
210
  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)

211
instance (Monad m, Error a, Monoid a) => Alternative (ResultT a m) where
212
213
214
  empty = mzero
  (<|>) = mplus

215
216
217
218
219
220
221
222
223
224
225
226
-- | 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

227
228
229
-- | Lift a 'Result' value to any 'MonadError'. Since 'ResultT' is itself its
-- instance, it's a generalization of
-- @Monad m => GenericResult a b -> ResultT a m b@.
Petr Pudlak's avatar
Petr Pudlak committed
230
231
232
toError :: (MonadError e m) => GenericResult e a -> m a
toError = genericResult throwError return
{-# INLINE toError #-}
233

234
235
236
237
238
-- | Lift a 'ResultT' value into any 'MonadError' with the same base monad.
toErrorBase :: (MonadBase b m, MonadError e m) => ResultT e b a -> m a
toErrorBase = (toError =<<) . liftBase . runResultT
{-# INLINE toErrorBase #-}

239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
-- | 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
255
256
-- | Simple checker for whether a 'GenericResult' is OK.
isOk :: GenericResult a b -> Bool
257
isOk (Ok _) = True
Iustin Pop's avatar
Iustin Pop committed
258
isOk _      = False
259

Iustin Pop's avatar
Iustin Pop committed
260
261
-- | Simple checker for whether a 'GenericResult' is a failure.
isBad :: GenericResult a b -> Bool
262
263
isBad = not . isOk

264
265
-- | Simple filter returning only OK values of GenericResult
justOk :: [GenericResult a b] -> [b]
266
267
268
269
270
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))
271

272
-- | Converter from Either to 'GenericResult'.
Iustin Pop's avatar
Iustin Pop committed
273
274
275
eitherToResult :: Either a b -> GenericResult a b
eitherToResult (Left  s) = Bad s
eitherToResult (Right v) = Ok  v
Iustin Pop's avatar
Iustin Pop committed
276

277
278
279
280
281
282
-- | Annotate an error with an ownership information, lifting it to a
-- 'MonadError'. Since 'Result' is an instance of 'MonadError' itself,
-- it's a generalization of type @String -> Result a -> Result a@.
-- See also 'toErrorStr'.
annotateResult :: (MonadError e m, Error e) => String -> Result a -> m a
annotateResult owner = toErrorStr . annotateError owner
Iustin Pop's avatar
Iustin Pop committed
283

284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
-- | 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 #-}

311
312
313
314
315
316
-- | If the first computation fails, run the second one.
-- Unlike 'mplus' instance for 'ResultT', this doesn't require
-- the 'Monoid' constrait.
orElse :: (MonadError e m) => m a -> m a -> m a
orElse x y = catchError x (const y)

317
318
319
320
-- | 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
321
322
323
324
325
326
327
328
-- * 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

329
330
331
332
333
334
-- | 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
335
336
337
338
339
340
341
-- * Lookup of partial names functionality

-- | The priority of a match in a lookup result.
data MatchPriority = ExactMatch
                   | MultipleMatch
                   | PartialMatch
                   | FailMatch
342
                   deriving (Show, Enum, Eq, Ord)
Iustin Pop's avatar
Iustin Pop committed
343
344
345
346
347
348

-- | 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
349
  } deriving (Show)
Iustin Pop's avatar
Iustin Pop committed
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407

-- | 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
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422

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