BasicTypes.hs 6.67 KB
Newer Older
1
2
{-

Iustin Pop's avatar
Iustin Pop committed
3
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

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
  ( Result(..)
24
25
  , ResultT(..)
  , resultT
26
27
28
  , isOk
  , isBad
  , eitherToResult
Iustin Pop's avatar
Iustin Pop committed
29
  , annotateResult
Iustin Pop's avatar
Iustin Pop committed
30
  , annotateIOError
Iustin Pop's avatar
Iustin Pop committed
31
32
33
34
35
36
37
38
  , select
  , LookupResult(..)
  , MatchPriority(..)
  , lookupName
  , goodLookupResult
  , goodMatchPriority
  , prefixMatch
  , compareNameComponent
39
40
  ) where

41
import Control.Applicative
42
import Control.Monad
43
import Control.Monad.Trans
Iustin Pop's avatar
Iustin Pop committed
44
45
import Data.Function
import Data.List
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

-- | This is similar to the JSON library Result type - /very/ similar,
-- but we want to use it in multiple places, so we abstract it into a
-- mini-library here.
--
-- The failure value for this monad is simply a string.
data Result a
    = Bad String
    | Ok a
    deriving (Show, Read, Eq)

instance Monad Result where
  (>>=) (Bad x) _ = Bad x
  (>>=) (Ok x) fn = fn x
  return = Ok
  fail = Bad

63
64
65
66
instance Functor Result where
  fmap _ (Bad msg) = Bad msg
  fmap fn (Ok val) = Ok (fn val)

67
68
69
70
71
72
73
74
instance MonadPlus Result where
  mzero = Bad "zero Result when used as MonadPlus"
  -- for mplus, when we 'add' two Bad values, we concatenate their
  -- error descriptions
  (Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y)
  (Bad _) `mplus` x = x
  x@(Ok _) `mplus` _ = x

75
76
77
78
79
80
instance Applicative Result where
  pure = Ok
  (Bad f) <*> _       = Bad f
  _       <*> (Bad x) = Bad x
  (Ok f)  <*> (Ok x)  = Ok $ f x

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
-- | This is a monad transformation for Result. It's implementation is
-- based on the implementations of MaybeT and ErrorT.
newtype ResultT m a = ResultT {runResultT :: m (Result a)}

instance (Monad m) => Monad (ResultT m) where
  fail err = ResultT (return $ Bad err)
  return = lift . return
  x >>= f = ResultT $ do
              a <- runResultT x
              case a of
                Ok val -> runResultT $ f val
                Bad err -> return $ Bad err

instance MonadTrans ResultT where
  lift x = ResultT (liftM Ok x)

instance (MonadIO m) => MonadIO (ResultT m) where
  liftIO = lift . liftIO

-- | Lift a `Result` value to a `ResultT`.
resultT :: Monad m => Result a -> ResultT m a
resultT = ResultT . return

104
105
106
107
108
109
110
111
112
113
114
115
116
-- | Simple checker for whether a 'Result' is OK.
isOk :: Result a -> Bool
isOk (Ok _) = True
isOk _ = False

-- | Simple checker for whether a 'Result' is a failure.
isBad :: Result a  -> Bool
isBad = not . isOk

-- | Converter from Either String to 'Result'.
eitherToResult :: Either String a -> Result a
eitherToResult (Left s) = Bad s
eitherToResult (Right v) = Ok v
Iustin Pop's avatar
Iustin Pop committed
117
118
119
120
121

-- | Annotate a Result with an ownership information.
annotateResult :: String -> Result a -> Result a
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
annotateResult _ v = v
Iustin Pop's avatar
Iustin Pop committed
122
123
124
125
126
127

-- | Annotates and transforms IOErrors into a Result type. This can be
-- used in the error handler argument to 'catch', for example.
annotateIOError :: String -> IOError -> IO (Result a)
annotateIOError description exc =
  return . Bad $ description ++ ": " ++ show exc
Iustin Pop's avatar
Iustin Pop committed
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209

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

-- * Lookup of partial names functionality

-- | The priority of a match in a lookup result.
data MatchPriority = ExactMatch
                   | MultipleMatch
                   | PartialMatch
                   | FailMatch
                   deriving (Show, Read, Enum, Eq, Ord)

-- | 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
  } deriving (Show, Read)

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