## root / src / Ganeti / BasicTypes.hs @ 95e683c6

History | View | Annotate | Download (9.3 kB)

1 |
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} |
---|---|

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

35 |
, eitherToResult |

36 |
, annotateResult |

37 |
, iterateOk |

38 |
, select |

39 |
, LookupResult(..) |

40 |
, MatchPriority(..) |

41 |
, lookupName |

42 |
, goodLookupResult |

43 |
, goodMatchPriority |

44 |
, prefixMatch |

45 |
, compareNameComponent |

46 |
, ListSet(..) |

47 |
, emptyListSet |

48 |
) where |

49 | |

50 |
import Control.Applicative |

51 |
import Control.Monad |

52 |
import Control.Monad.Error.Class |

53 |
import Control.Monad.Trans |

54 |
import Data.Function |

55 |
import Data.List |

56 |
import Data.Maybe |

57 |
import Data.Monoid |

58 |
import Data.Set (Set) |

59 |
import qualified Data.Set as Set (empty) |

60 |
import Text.JSON (JSON) |

61 |
import qualified Text.JSON as JSON (readJSON, showJSON) |

62 | |

63 |
-- | Generic monad for our error handling mechanisms. |

64 |
data GenericResult a b |

65 |
= Bad a |

66 |
| Ok b |

67 |
deriving (Show, Eq) |

68 | |

69 |
-- | Sum type structure of GenericResult. |

70 |
genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c |

71 |
genericResult f _ (Bad a) = f a |

72 |
genericResult _ g (Ok b) = g b |

73 | |

74 |
-- | Type alias for a string Result. |

75 |
type Result = GenericResult String |

76 | |

77 |
-- | Type class for things that can be built from strings. |

78 |
class FromString a where |

79 |
mkFromString :: String -> a |

80 | |

81 |
-- | Trivial 'String' instance; requires FlexibleInstances extension |

82 |
-- though. |

83 |
instance FromString [Char] where |

84 |
mkFromString = id |

85 | |

86 |
-- | 'Monad' instance for 'GenericResult'. |

87 |
instance (FromString a) => Monad (GenericResult a) where |

88 |
(>>=) (Bad x) _ = Bad x |

89 |
(>>=) (Ok x) fn = fn x |

90 |
return = Ok |

91 |
fail = Bad . mkFromString |

92 | |

93 |
instance Functor (GenericResult a) where |

94 |
fmap _ (Bad msg) = Bad msg |

95 |
fmap fn (Ok val) = Ok (fn val) |

96 | |

97 |
instance (FromString a, Monoid a) => MonadPlus (GenericResult a) where |

98 |
mzero = Bad $ mkFromString "zero Result when used as MonadPlus" |

99 |
-- for mplus, when we 'add' two Bad values, we concatenate their |

100 |
-- error descriptions |

101 |
(Bad x) `mplus` (Bad y) = Bad (x `mappend` mkFromString "; " `mappend` y) |

102 |
(Bad _) `mplus` x = x |

103 |
x@(Ok _) `mplus` _ = x |

104 | |

105 |
instance (FromString a) => MonadError a (GenericResult a) where |

106 |
throwError = Bad |

107 |
catchError x h = genericResult h (const x) x |

108 | |

109 |
instance Applicative (GenericResult a) where |

110 |
pure = Ok |

111 |
(Bad f) <*> _ = Bad f |

112 |
_ <*> (Bad x) = Bad x |

113 |
(Ok f) <*> (Ok x) = Ok $ f x |

114 | |

115 |
-- | This is a monad transformation for Result. It's implementation is |

116 |
-- based on the implementations of MaybeT and ErrorT. |

117 |
newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)} |

118 | |

119 |
-- | Eliminates a 'ResultT' value given appropriate continuations |

120 |
elimResultT :: (Monad m) |

121 |
=> (a -> ResultT a' m b') |

122 |
-> (b -> ResultT a' m b') |

123 |
-> ResultT a m b |

124 |
-> ResultT a' m b' |

125 |
elimResultT l r = ResultT . (runResultT . result <=< runResultT) |

126 |
where |

127 |
result (Ok x) = r x |

128 |
result (Bad e) = l e |

129 |
{-# INLINE elimResultT #-} |

130 | |

131 |
instance (Monad f) => Functor (ResultT a f) where |

132 |
fmap f = ResultT . liftM (fmap f) . runResultT |

133 | |

134 |
instance (Monad m, FromString a) => Applicative (ResultT a m) where |

135 |
pure = return |

136 |
(<*>) = ap |

137 | |

138 |
instance (Monad m, FromString a) => Monad (ResultT a m) where |

139 |
fail err = ResultT (return . Bad $ mkFromString err) |

140 |
return = lift . return |

141 |
(>>=) = flip (elimResultT throwError) |

142 | |

143 |
instance (Monad m, FromString a) => MonadError a (ResultT a m) where |

144 |
throwError = resultT . Bad |

145 |
catchError x h = elimResultT h return x |

146 | |

147 |
instance MonadTrans (ResultT a) where |

148 |
lift = ResultT . liftM Ok |

149 | |

150 |
instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where |

151 |
liftIO = lift . liftIO |

152 | |

153 |
instance (Monad m, FromString a, Monoid a) => MonadPlus (ResultT a m) where |

154 |
mzero = ResultT $ return mzero |

155 |
-- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit |

156 |
-- more complicated than 'mplus' of 'GenericResult'. |

157 |
mplus x y = elimResultT combine return x |

158 |
where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y) |

159 | |

160 |
-- | Lift a `Result` value to a `ResultT`. |

161 |
resultT :: Monad m => GenericResult a b -> ResultT a m b |

162 |
resultT = ResultT . return |

163 | |

164 |
-- | Simple checker for whether a 'GenericResult' is OK. |

165 |
isOk :: GenericResult a b -> Bool |

166 |
isOk (Ok _) = True |

167 |
isOk _ = False |

168 | |

169 |
-- | Simple checker for whether a 'GenericResult' is a failure. |

170 |
isBad :: GenericResult a b -> Bool |

171 |
isBad = not . isOk |

172 | |

173 |
-- | Simple filter returning only OK values of GenericResult |

174 |
justOk :: [GenericResult a b] -> [b] |

175 |
justOk = mapMaybe (genericResult (const Nothing) Just) |

176 | |

177 |
-- | Simple filter returning only Bad values of GenericResult |

178 |
justBad :: [GenericResult a b] -> [a] |

179 |
justBad = mapMaybe (genericResult Just (const Nothing)) |

180 | |

181 |
-- | Converter from Either to 'GenericResult'. |

182 |
eitherToResult :: Either a b -> GenericResult a b |

183 |
eitherToResult (Left s) = Bad s |

184 |
eitherToResult (Right v) = Ok v |

185 | |

186 |
-- | Annotate a Result with an ownership information. |

187 |
annotateResult :: String -> Result a -> Result a |

188 |
annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s |

189 |
annotateResult _ v = v |

190 | |

191 |
-- | Iterate while Ok. |

192 |
iterateOk :: (a -> GenericResult b a) -> a -> [a] |

193 |
iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a) |

194 | |

195 |
-- * Misc functionality |

196 | |

197 |
-- | Return the first result with a True condition, or the default otherwise. |

198 |
select :: a -- ^ default result |

199 |
-> [(Bool, a)] -- ^ list of \"condition, result\" |

200 |
-> a -- ^ first result which has a True condition, or default |

201 |
select def = maybe def snd . find fst |

202 | |

203 |
-- * Lookup of partial names functionality |

204 | |

205 |
-- | The priority of a match in a lookup result. |

206 |
data MatchPriority = ExactMatch |

207 |
| MultipleMatch |

208 |
| PartialMatch |

209 |
| FailMatch |

210 |
deriving (Show, Enum, Eq, Ord) |

211 | |

212 |
-- | The result of a name lookup in a list. |

213 |
data LookupResult = LookupResult |

214 |
{ lrMatchPriority :: MatchPriority -- ^ The result type |

215 |
-- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise |

216 |
, lrContent :: String |

217 |
} deriving (Show) |

218 | |

219 |
-- | Lookup results have an absolute preference ordering. |

220 |
instance Eq LookupResult where |

221 |
(==) = (==) `on` lrMatchPriority |

222 | |

223 |
instance Ord LookupResult where |

224 |
compare = compare `on` lrMatchPriority |

225 | |

226 |
-- | Check for prefix matches in names. |

227 |
-- Implemented in Ganeti core utils.text.MatchNameComponent |

228 |
-- as the regexp r"^%s(\..*)?$" % re.escape(key) |

229 |
prefixMatch :: String -- ^ Lookup |

230 |
-> String -- ^ Full name |

231 |
-> Bool -- ^ Whether there is a prefix match |

232 |
prefixMatch = isPrefixOf . (++ ".") |

233 | |

234 |
-- | Is the lookup priority a "good" one? |

235 |
goodMatchPriority :: MatchPriority -> Bool |

236 |
goodMatchPriority ExactMatch = True |

237 |
goodMatchPriority PartialMatch = True |

238 |
goodMatchPriority _ = False |

239 | |

240 |
-- | Is the lookup result an actual match? |

241 |
goodLookupResult :: LookupResult -> Bool |

242 |
goodLookupResult = goodMatchPriority . lrMatchPriority |

243 | |

244 |
-- | Compares a canonical name and a lookup string. |

245 |
compareNameComponent :: String -- ^ Canonical (target) name |

246 |
-> String -- ^ Partial (lookup) name |

247 |
-> LookupResult -- ^ Result of the lookup |

248 |
compareNameComponent cnl lkp = |

249 |
select (LookupResult FailMatch lkp) |

250 |
[ (cnl == lkp , LookupResult ExactMatch cnl) |

251 |
, (prefixMatch lkp cnl , LookupResult PartialMatch cnl) |

252 |
] |

253 | |

254 |
-- | Lookup a string and choose the best result. |

255 |
chooseLookupResult :: String -- ^ Lookup key |

256 |
-> String -- ^ String to compare to the lookup key |

257 |
-> LookupResult -- ^ Previous result |

258 |
-> LookupResult -- ^ New result |

259 |
chooseLookupResult lkp cstr old = |

260 |
-- default: use class order to pick the minimum result |

261 |
select (min new old) |

262 |
-- special cases: |

263 |
-- short circuit if the new result is an exact match |

264 |
[ (lrMatchPriority new == ExactMatch, new) |

265 |
-- if both are partial matches generate a multiple match |

266 |
, (partial2, LookupResult MultipleMatch lkp) |

267 |
] where new = compareNameComponent cstr lkp |

268 |
partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new] |

269 | |

270 |
-- | Find the canonical name for a lookup string in a list of names. |

271 |
lookupName :: [String] -- ^ List of keys |

272 |
-> String -- ^ Lookup string |

273 |
-> LookupResult -- ^ Result of the lookup |

274 |
lookupName l s = foldr (chooseLookupResult s) |

275 |
(LookupResult FailMatch s) l |

276 | |

277 |
-- | Wrapper for a Haskell 'Set' |

278 |
-- |

279 |
-- This type wraps a 'Set' and it is used in the Haskell to Python |

280 |
-- opcode generation to transform a Haskell 'Set' into a Python 'list' |

281 |
-- without duplicate elements. |

282 |
newtype ListSet a = ListSet { unListSet :: Set a } |

283 |
deriving (Eq, Show) |

284 | |

285 |
instance (Ord a, JSON a) => JSON (ListSet a) where |

286 |
showJSON = JSON.showJSON . unListSet |

287 |
readJSON = liftM ListSet . JSON.readJSON |

288 | |

289 |
emptyListSet :: ListSet a |

290 |
emptyListSet = ListSet Set.empty |