Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / BasicTypes.hs @ 82b948e4

History | View | Annotate | Download (7.2 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
  , eitherToResult
34
  , annotateResult
35
  , iterateOk
36
  , select
37
  , LookupResult(..)
38
  , MatchPriority(..)
39
  , lookupName
40
  , goodLookupResult
41
  , goodMatchPriority
42
  , prefixMatch
43
  , compareNameComponent
44
  ) where
45

    
46
import Control.Applicative
47
import Control.Monad
48
import Control.Monad.Trans
49
import Data.Function
50
import Data.List
51

    
52
-- | Generic monad for our error handling mechanisms.
53
data GenericResult a b
54
  = Bad a
55
  | Ok b
56
    deriving (Show, Eq)
57

    
58
-- | Sum type structure of GenericResult.
59
genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c
60
genericResult f _ (Bad a) = f a
61
genericResult _ g (Ok b) = g b
62

    
63
-- | Type alias for a string Result.
64
type Result = GenericResult String
65

    
66
-- | Type class for things that can be built from strings.
67
class FromString a where
68
  mkFromString :: String -> a
69

    
70
-- | Trivial 'String' instance; requires FlexibleInstances extension
71
-- though.
72
instance FromString [Char] where
73
  mkFromString = id
74

    
75
-- | 'Monad' instance for 'GenericResult'.
76
instance (FromString a) => Monad (GenericResult a) where
77
  (>>=) (Bad x) _ = Bad x
78
  (>>=) (Ok x) fn = fn x
79
  return = Ok
80
  fail   = Bad . mkFromString
81

    
82
instance Functor (GenericResult a) where
83
  fmap _ (Bad msg) = Bad msg
84
  fmap fn (Ok val) = Ok (fn val)
85

    
86
instance MonadPlus (GenericResult String) where
87
  mzero = Bad "zero Result when used as MonadPlus"
88
  -- for mplus, when we 'add' two Bad values, we concatenate their
89
  -- error descriptions
90
  (Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y)
91
  (Bad _) `mplus` x = x
92
  x@(Ok _) `mplus` _ = x
93

    
94
instance Applicative (GenericResult a) where
95
  pure = Ok
96
  (Bad f) <*> _       = Bad f
97
  _       <*> (Bad x) = Bad x
98
  (Ok f)  <*> (Ok x)  = Ok $ f x
99

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

    
104
instance (Monad m, FromString a) => Monad (ResultT a m) where
105
  fail err = ResultT (return . Bad $ mkFromString err)
106
  return   = lift . return
107
  x >>= f  = ResultT $ do
108
               a <- runResultT x
109
               case a of
110
                 Ok val -> runResultT $ f val
111
                 Bad err -> return $ Bad err
112

    
113
instance MonadTrans (ResultT a) where
114
  lift x = ResultT (liftM Ok x)
115

    
116
instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where
117
  liftIO = lift . liftIO
118

    
119
-- | Lift a `Result` value to a `ResultT`.
120
resultT :: Monad m => GenericResult a b -> ResultT a m b
121
resultT = ResultT . return
122

    
123
-- | Simple checker for whether a 'GenericResult' is OK.
124
isOk :: GenericResult a b -> Bool
125
isOk (Ok _) = True
126
isOk _      = False
127

    
128
-- | Simple checker for whether a 'GenericResult' is a failure.
129
isBad :: GenericResult a b -> Bool
130
isBad = not . isOk
131

    
132
-- | Converter from Either to 'GenericResult'.
133
eitherToResult :: Either a b -> GenericResult a b
134
eitherToResult (Left  s) = Bad s
135
eitherToResult (Right v) = Ok  v
136

    
137
-- | Annotate a Result with an ownership information.
138
annotateResult :: String -> Result a -> Result a
139
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
140
annotateResult _ v = v
141

    
142
-- | Iterate while Ok.
143
iterateOk :: (a -> GenericResult b a) -> a -> [a]
144
iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a)
145

    
146
-- * Misc functionality
147

    
148
-- | Return the first result with a True condition, or the default otherwise.
149
select :: a            -- ^ default result
150
       -> [(Bool, a)]  -- ^ list of \"condition, result\"
151
       -> a            -- ^ first result which has a True condition, or default
152
select def = maybe def snd . find fst
153

    
154
-- * Lookup of partial names functionality
155

    
156
-- | The priority of a match in a lookup result.
157
data MatchPriority = ExactMatch
158
                   | MultipleMatch
159
                   | PartialMatch
160
                   | FailMatch
161
                   deriving (Show, Enum, Eq, Ord)
162

    
163
-- | The result of a name lookup in a list.
164
data LookupResult = LookupResult
165
  { lrMatchPriority :: MatchPriority -- ^ The result type
166
  -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
167
  , lrContent :: String
168
  } deriving (Show)
169

    
170
-- | Lookup results have an absolute preference ordering.
171
instance Eq LookupResult where
172
  (==) = (==) `on` lrMatchPriority
173

    
174
instance Ord LookupResult where
175
  compare = compare `on` lrMatchPriority
176

    
177
-- | Check for prefix matches in names.
178
-- Implemented in Ganeti core utils.text.MatchNameComponent
179
-- as the regexp r"^%s(\..*)?$" % re.escape(key)
180
prefixMatch :: String  -- ^ Lookup
181
            -> String  -- ^ Full name
182
            -> Bool    -- ^ Whether there is a prefix match
183
prefixMatch = isPrefixOf . (++ ".")
184

    
185
-- | Is the lookup priority a "good" one?
186
goodMatchPriority :: MatchPriority -> Bool
187
goodMatchPriority ExactMatch = True
188
goodMatchPriority PartialMatch = True
189
goodMatchPriority _ = False
190

    
191
-- | Is the lookup result an actual match?
192
goodLookupResult :: LookupResult -> Bool
193
goodLookupResult = goodMatchPriority . lrMatchPriority
194

    
195
-- | Compares a canonical name and a lookup string.
196
compareNameComponent :: String        -- ^ Canonical (target) name
197
                     -> String        -- ^ Partial (lookup) name
198
                     -> LookupResult  -- ^ Result of the lookup
199
compareNameComponent cnl lkp =
200
  select (LookupResult FailMatch lkp)
201
  [ (cnl == lkp          , LookupResult ExactMatch cnl)
202
  , (prefixMatch lkp cnl , LookupResult PartialMatch cnl)
203
  ]
204

    
205
-- | Lookup a string and choose the best result.
206
chooseLookupResult :: String       -- ^ Lookup key
207
                   -> String       -- ^ String to compare to the lookup key
208
                   -> LookupResult -- ^ Previous result
209
                   -> LookupResult -- ^ New result
210
chooseLookupResult lkp cstr old =
211
  -- default: use class order to pick the minimum result
212
  select (min new old)
213
  -- special cases:
214
  -- short circuit if the new result is an exact match
215
  [ (lrMatchPriority new == ExactMatch, new)
216
  -- if both are partial matches generate a multiple match
217
  , (partial2, LookupResult MultipleMatch lkp)
218
  ] where new = compareNameComponent cstr lkp
219
          partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new]
220

    
221
-- | Find the canonical name for a lookup string in a list of names.
222
lookupName :: [String]      -- ^ List of keys
223
           -> String        -- ^ Lookup string
224
           -> LookupResult  -- ^ Result of the lookup
225
lookupName l s = foldr (chooseLookupResult s)
226
                       (LookupResult FailMatch s) l