Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / BasicTypes.hs @ e817723c

History | View | Annotate | Download (8 kB)

1
{-# LANGUAGE FlexibleInstances #-}
2

    
3
{-
4

    
5
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
6

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

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

    
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
20
02110-1301, USA.
21

    
22
-}
23

    
24
module Ganeti.BasicTypes
25
  ( GenericResult(..)
26
  , genericResult
27
  , Result
28
  , ResultT(..)
29
  , resultT
30
  , FromString(..)
31
  , isOk
32
  , isBad
33
  , justOk
34
  , eitherToResult
35
  , annotateResult
36
  , iterateOk
37
  , select
38
  , LookupResult(..)
39
  , MatchPriority(..)
40
  , lookupName
41
  , goodLookupResult
42
  , goodMatchPriority
43
  , prefixMatch
44
  , compareNameComponent
45
  , ListSet(..)
46
  , emptyListSet
47
  ) where
48

    
49
import Control.Applicative
50
import Control.Monad
51
import Control.Monad.Trans
52
import Data.Function
53
import Data.List
54
import Data.Set (Set)
55
import qualified Data.Set as Set (empty)
56
import Text.JSON (JSON)
57
import qualified Text.JSON as JSON (readJSON, showJSON)
58

    
59
-- | Generic monad for our error handling mechanisms.
60
data GenericResult a b
61
  = Bad a
62
  | Ok b
63
    deriving (Show, Eq)
64

    
65
-- | Sum type structure of GenericResult.
66
genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c
67
genericResult f _ (Bad a) = f a
68
genericResult _ g (Ok b) = g b
69

    
70
-- | Type alias for a string Result.
71
type Result = GenericResult String
72

    
73
-- | Type class for things that can be built from strings.
74
class FromString a where
75
  mkFromString :: String -> a
76

    
77
-- | Trivial 'String' instance; requires FlexibleInstances extension
78
-- though.
79
instance FromString [Char] where
80
  mkFromString = id
81

    
82
-- | 'Monad' instance for 'GenericResult'.
83
instance (FromString a) => Monad (GenericResult a) where
84
  (>>=) (Bad x) _ = Bad x
85
  (>>=) (Ok x) fn = fn x
86
  return = Ok
87
  fail   = Bad . mkFromString
88

    
89
instance Functor (GenericResult a) where
90
  fmap _ (Bad msg) = Bad msg
91
  fmap fn (Ok val) = Ok (fn val)
92

    
93
instance MonadPlus (GenericResult String) where
94
  mzero = Bad "zero Result when used as MonadPlus"
95
  -- for mplus, when we 'add' two Bad values, we concatenate their
96
  -- error descriptions
97
  (Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y)
98
  (Bad _) `mplus` x = x
99
  x@(Ok _) `mplus` _ = x
100

    
101
instance Applicative (GenericResult a) where
102
  pure = Ok
103
  (Bad f) <*> _       = Bad f
104
  _       <*> (Bad x) = Bad x
105
  (Ok f)  <*> (Ok x)  = Ok $ f x
106

    
107
-- | This is a monad transformation for Result. It's implementation is
108
-- based on the implementations of MaybeT and ErrorT.
109
newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}
110

    
111
instance (Monad m, FromString a) => Monad (ResultT a m) where
112
  fail err = ResultT (return . Bad $ mkFromString err)
113
  return   = lift . return
114
  x >>= f  = ResultT $ do
115
               a <- runResultT x
116
               case a of
117
                 Ok val -> runResultT $ f val
118
                 Bad err -> return $ Bad err
119

    
120
instance MonadTrans (ResultT a) where
121
  lift x = ResultT (liftM Ok x)
122

    
123
instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where
124
  liftIO = lift . liftIO
125

    
126
-- | Lift a `Result` value to a `ResultT`.
127
resultT :: Monad m => GenericResult a b -> ResultT a m b
128
resultT = ResultT . return
129

    
130
-- | Simple checker for whether a 'GenericResult' is OK.
131
isOk :: GenericResult a b -> Bool
132
isOk (Ok _) = True
133
isOk _      = False
134

    
135
-- | Simple checker for whether a 'GenericResult' is a failure.
136
isBad :: GenericResult a b -> Bool
137
isBad = not . isOk
138

    
139
-- | Simple filter returning only OK values of GenericResult
140
justOk :: [GenericResult a b] -> [b]
141
justOk [] = []
142
justOk (x:xs) = case x of
143
  Ok  v -> v:justOk xs
144
  Bad _ -> justOk xs
145

    
146
-- | Converter from Either to 'GenericResult'.
147
eitherToResult :: Either a b -> GenericResult a b
148
eitherToResult (Left  s) = Bad s
149
eitherToResult (Right v) = Ok  v
150

    
151
-- | Annotate a Result with an ownership information.
152
annotateResult :: String -> Result a -> Result a
153
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
154
annotateResult _ v = v
155

    
156
-- | Iterate while Ok.
157
iterateOk :: (a -> GenericResult b a) -> a -> [a]
158
iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a)
159

    
160
-- * Misc functionality
161

    
162
-- | Return the first result with a True condition, or the default otherwise.
163
select :: a            -- ^ default result
164
       -> [(Bool, a)]  -- ^ list of \"condition, result\"
165
       -> a            -- ^ first result which has a True condition, or default
166
select def = maybe def snd . find fst
167

    
168
-- * Lookup of partial names functionality
169

    
170
-- | The priority of a match in a lookup result.
171
data MatchPriority = ExactMatch
172
                   | MultipleMatch
173
                   | PartialMatch
174
                   | FailMatch
175
                   deriving (Show, Enum, Eq, Ord)
176

    
177
-- | The result of a name lookup in a list.
178
data LookupResult = LookupResult
179
  { lrMatchPriority :: MatchPriority -- ^ The result type
180
  -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
181
  , lrContent :: String
182
  } deriving (Show)
183

    
184
-- | Lookup results have an absolute preference ordering.
185
instance Eq LookupResult where
186
  (==) = (==) `on` lrMatchPriority
187

    
188
instance Ord LookupResult where
189
  compare = compare `on` lrMatchPriority
190

    
191
-- | Check for prefix matches in names.
192
-- Implemented in Ganeti core utils.text.MatchNameComponent
193
-- as the regexp r"^%s(\..*)?$" % re.escape(key)
194
prefixMatch :: String  -- ^ Lookup
195
            -> String  -- ^ Full name
196
            -> Bool    -- ^ Whether there is a prefix match
197
prefixMatch = isPrefixOf . (++ ".")
198

    
199
-- | Is the lookup priority a "good" one?
200
goodMatchPriority :: MatchPriority -> Bool
201
goodMatchPriority ExactMatch = True
202
goodMatchPriority PartialMatch = True
203
goodMatchPriority _ = False
204

    
205
-- | Is the lookup result an actual match?
206
goodLookupResult :: LookupResult -> Bool
207
goodLookupResult = goodMatchPriority . lrMatchPriority
208

    
209
-- | Compares a canonical name and a lookup string.
210
compareNameComponent :: String        -- ^ Canonical (target) name
211
                     -> String        -- ^ Partial (lookup) name
212
                     -> LookupResult  -- ^ Result of the lookup
213
compareNameComponent cnl lkp =
214
  select (LookupResult FailMatch lkp)
215
  [ (cnl == lkp          , LookupResult ExactMatch cnl)
216
  , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
217
  ]
218

    
219
-- | Lookup a string and choose the best result.
220
chooseLookupResult :: String       -- ^ Lookup key
221
                   -> String       -- ^ String to compare to the lookup key
222
                   -> LookupResult -- ^ Previous result
223
                   -> LookupResult -- ^ New result
224
chooseLookupResult lkp cstr old =
225
  -- default: use class order to pick the minimum result
226
  select (min new old)
227
  -- special cases:
228
  -- short circuit if the new result is an exact match
229
  [ (lrMatchPriority new == ExactMatch, new)
230
  -- if both are partial matches generate a multiple match
231
  , (partial2, LookupResult MultipleMatch lkp)
232
  ] where new = compareNameComponent cstr lkp
233
          partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
234

    
235
-- | Find the canonical name for a lookup string in a list of names.
236
lookupName :: [String]      -- ^ List of keys
237
           -> String        -- ^ Lookup string
238
           -> LookupResult  -- ^ Result of the lookup
239
lookupName l s = foldr (chooseLookupResult s)
240
                       (LookupResult FailMatch s) l
241

    
242
-- | Wrapper for a Haskell 'Set'
243
--
244
-- This type wraps a 'Set' and it is used in the Haskell to Python
245
-- opcode generation to transform a Haskell 'Set' into a Python 'list'
246
-- without duplicate elements.
247
newtype ListSet a = ListSet { unListSet :: Set a }
248
  deriving (Eq, Show)
249

    
250
instance (Ord a, JSON a) => JSON (ListSet a) where
251
  showJSON = JSON.showJSON . unListSet
252
  readJSON = liftM ListSet . JSON.readJSON
253

    
254
emptyListSet :: ListSet a
255
emptyListSet = ListSet Set.empty