## root / src / Ganeti / BasicTypes.hs @ 0efada2a

History | View | Annotate | Download (14.3 kB)

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

2 |
{-# LANGUAGE FlexibleContexts #-} |

3 |
{-# LANGUAGE MultiParamTypeClasses #-} |

4 |
{-# LANGUAGE TypeFamilies #-} |

5 | |

6 |
{- |

7 | |

8 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |

9 | |

10 |
This program is free software; you can redistribute it and/or modify |

11 |
it under the terms of the GNU General Public License as published by |

12 |
the Free Software Foundation; either version 2 of the License, or |

13 |
(at your option) any later version. |

14 | |

15 |
This program is distributed in the hope that it will be useful, but |

16 |
WITHOUT ANY WARRANTY; without even the implied warranty of |

17 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |

18 |
General Public License for more details. |

19 | |

20 |
You should have received a copy of the GNU General Public License |

21 |
along with this program; if not, write to the Free Software |

22 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |

23 |
02110-1301, USA. |

24 | |

25 |
-} |

26 | |

27 |
module Ganeti.BasicTypes |

28 |
( GenericResult(..) |

29 |
, genericResult |

30 |
, Result |

31 |
, ResultT(..) |

32 |
, mkResultT |

33 |
, withError |

34 |
, withErrorT |

35 |
, toError |

36 |
, toErrorBase |

37 |
, toErrorStr |

38 |
, Error(..) -- re-export from Control.Monad.Error |

39 |
, MonadIO(..) -- re-export from Control.Monad.IO.Class |

40 |
, isOk |

41 |
, isBad |

42 |
, justOk |

43 |
, justBad |

44 |
, eitherToResult |

45 |
, annotateResult |

46 |
, annotateError |

47 |
, failError |

48 |
, catchErrorT |

49 |
, handleErrorT |

50 |
, iterateOk |

51 |
, select |

52 |
, runListHead |

53 |
, LookupResult(..) |

54 |
, MatchPriority(..) |

55 |
, lookupName |

56 |
, goodLookupResult |

57 |
, goodMatchPriority |

58 |
, prefixMatch |

59 |
, compareNameComponent |

60 |
, ListSet(..) |

61 |
, emptyListSet |

62 |
) where |

63 | |

64 |
import Control.Applicative |

65 |
import Control.Exception (try) |

66 |
import Control.Monad |

67 |
import Control.Monad.Base |

68 |
import Control.Monad.Error.Class |

69 |
import Control.Monad.Trans |

70 |
import Control.Monad.Trans.Control |

71 |
import Data.Function |

72 |
import Data.List |

73 |
import Data.Maybe |

74 |
import Data.Monoid |

75 |
import Data.Set (Set) |

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

77 |
import Text.JSON (JSON) |

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

79 | |

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

81 |
data GenericResult a b |

82 |
= Bad a |

83 |
| Ok b |

84 |
deriving (Show, Eq) |

85 | |

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

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

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

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

90 |
{-# INLINE genericResult #-} |

91 | |

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

93 |
type Result = GenericResult String |

94 | |

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

96 |
instance (Error a) => Monad (GenericResult a) where |

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

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

99 |
return = Ok |

100 |
fail = Bad . strMsg |

101 | |

102 |
instance Functor (GenericResult a) where |

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

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

105 | |

106 |
instance (Error a, Monoid a) => MonadPlus (GenericResult a) where |

107 |
mzero = Bad $ strMsg "zero Result when used as MonadPlus" |

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

109 |
-- error descriptions |

110 |
(Bad x) `mplus` (Bad y) = Bad (x `mappend` strMsg "; " `mappend` y) |

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

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

113 | |

114 |
instance (Error a) => MonadError a (GenericResult a) where |

115 |
throwError = Bad |

116 |
{-# INLINE throwError #-} |

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

118 |
{-# INLINE catchError #-} |

119 | |

120 |
instance Applicative (GenericResult a) where |

121 |
pure = Ok |

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

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

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

125 | |

126 |
instance (Error a, Monoid a) => Alternative (GenericResult a) where |

127 |
empty = mzero |

128 |
(<|>) = mplus |

129 | |

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

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

132 |
-- |

133 |
-- 'ResultT' is very similar to @ErrorT@, but with one subtle difference: |

134 |
-- If 'mplus' combines two failing operations, errors of both of them |

135 |
-- are combined. |

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

137 | |

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

139 |
elimResultT :: (Monad m) |

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

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

142 |
-> ResultT a m b |

143 |
-> ResultT a' m b' |

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

145 |
where |

146 |
result (Ok x) = r x |

147 |
result (Bad e) = l e |

148 |
{-# INLINE elimResultT #-} |

149 | |

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

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

152 | |

153 |
instance (Monad m, Error a) => Applicative (ResultT a m) where |

154 |
pure = return |

155 |
(<*>) = ap |

156 | |

157 |
instance (Monad m, Error a) => Monad (ResultT a m) where |

158 |
fail err = ResultT (return . Bad $ strMsg err) |

159 |
return = lift . return |

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

161 | |

162 |
instance (Monad m, Error a) => MonadError a (ResultT a m) where |

163 |
throwError = ResultT . return . Bad |

164 |
catchError = catchErrorT |

165 | |

166 |
instance MonadTrans (ResultT a) where |

167 |
lift = ResultT . liftM Ok |

168 | |

169 |
-- | The instance catches any 'IOError' using 'try' and converts it into an |

170 |
-- error message using 'strMsg'. |

171 |
-- |

172 |
-- This way, monadic code within 'ResultT' that uses solely 'liftIO' to |

173 |
-- include 'IO' actions ensures that all IO exceptions are handled. |

174 |
-- |

175 |
-- Other exceptions (see instances of 'Exception') are not currently handled. |

176 |
-- This might be revised in the future. |

177 |
instance (MonadIO m, Error a) => MonadIO (ResultT a m) where |

178 |
liftIO = ResultT . liftIO |

179 |
. liftM (either (failError . show) return) |

180 |
. (try :: IO a -> IO (Either IOError a)) |

181 | |

182 |
instance (MonadBase IO m, Error a) => MonadBase IO (ResultT a m) where |

183 |
liftBase = ResultT . liftBase |

184 |
. liftM (either (failError . show) return) |

185 |
. (try :: IO a -> IO (Either IOError a)) |

186 | |

187 |
instance (Error a) => MonadTransControl (ResultT a) where |

188 |
newtype StT (ResultT a) b = StResultT { runStResultT :: GenericResult a b } |

189 |
liftWith f = ResultT . liftM return $ f (liftM StResultT . runResultT) |

190 |
restoreT = ResultT . liftM runStResultT |

191 |
{-# INLINE liftWith #-} |

192 |
{-# INLINE restoreT #-} |

193 | |

194 |
instance (Error a, MonadBaseControl IO m) |

195 |
=> MonadBaseControl IO (ResultT a m) where |

196 |
newtype StM (ResultT a m) b |

197 |
= StMResultT { runStMResultT :: ComposeSt (ResultT a) m b } |

198 |
liftBaseWith = defaultLiftBaseWith StMResultT |

199 |
restoreM = defaultRestoreM runStMResultT |

200 |
{-# INLINE liftBaseWith #-} |

201 |
{-# INLINE restoreM #-} |

202 | |

203 |
instance (Monad m, Error a, Monoid a) => MonadPlus (ResultT a m) where |

204 |
mzero = ResultT $ return mzero |

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

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

207 |
mplus x y = elimResultT combine return x |

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

209 | |

210 |
instance (Monad m, Error a, Monoid a) => Alternative (ResultT a m) where |

211 |
empty = mzero |

212 |
(<|>) = mplus |

213 | |

214 |
-- | Changes the error message of a result value, if present. |

215 |
-- Note that since 'GenericResult' is also a 'MonadError', this function |

216 |
-- is a generalization of |

217 |
-- @(Error e') => (e' -> e) -> GenericResult e' a -> GenericResult e a@ |

218 |
withError :: (MonadError e m) => (e' -> e) -> GenericResult e' a -> m a |

219 |
withError f = genericResult (throwError . f) return |

220 | |

221 |
-- | Changes the error message of a @ResultT@ value, if present. |

222 |
withErrorT :: (Monad m, Error e) |

223 |
=> (e' -> e) -> ResultT e' m a -> ResultT e m a |

224 |
withErrorT f = ResultT . liftM (withError f) . runResultT |

225 | |

226 |
-- | Lift a 'Result' value to any 'MonadError'. Since 'ResultT' is itself its |

227 |
-- instance, it's a generalization of |

228 |
-- @Monad m => GenericResult a b -> ResultT a m b@. |

229 |
toError :: (MonadError e m) => GenericResult e a -> m a |

230 |
toError = genericResult throwError return |

231 |
{-# INLINE toError #-} |

232 | |

233 |
-- | Lift a 'ResultT' value into any 'MonadError' with the same base monad. |

234 |
toErrorBase :: (MonadBase b m, MonadError e m) => ResultT e b a -> m a |

235 |
toErrorBase = (toError =<<) . liftBase . runResultT |

236 |
{-# INLINE toErrorBase #-} |

237 | |

238 |
-- | An alias for @withError strMsg@, which is often used to lift a pure error |

239 |
-- to a monad stack. See also 'annotateResult'. |

240 |
toErrorStr :: (MonadError e m, Error e) => Result a -> m a |

241 |
toErrorStr = withError strMsg |

242 | |

243 |
-- | Converts a monadic result with a 'String' message into |

244 |
-- a 'ResultT' with an arbitrary 'Error'. |

245 |
-- |

246 |
-- Expects that the given action has already taken care of any possible |

247 |
-- errors. In particular, if applied on @IO (Result a)@, any exceptions |

248 |
-- should be handled by the given action. |

249 |
-- |

250 |
-- See also 'toErrorStr'. |

251 |
mkResultT :: (Monad m, Error e) => m (Result a) -> ResultT e m a |

252 |
mkResultT = ResultT . liftM toErrorStr |

253 | |

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

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

256 |
isOk (Ok _) = True |

257 |
isOk _ = False |

258 | |

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

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

261 |
isBad = not . isOk |

262 | |

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

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

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

266 | |

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

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

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

270 | |

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

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

273 |
eitherToResult (Left s) = Bad s |

274 |
eitherToResult (Right v) = Ok v |

275 | |

276 |
-- | Annotate an error with an ownership information, lifting it to a |

277 |
-- 'MonadError'. Since 'Result' is an instance of 'MonadError' itself, |

278 |
-- it's a generalization of type @String -> Result a -> Result a@. |

279 |
-- See also 'toErrorStr'. |

280 |
annotateResult :: (MonadError e m, Error e) => String -> Result a -> m a |

281 |
annotateResult owner = toErrorStr . annotateError owner |

282 | |

283 |
-- | Annotate an error with an ownership information inside a 'MonadError'. |

284 |
-- See also 'annotateResult'. |

285 |
annotateError :: (MonadError e m, Error e, Monoid e) => String -> m a -> m a |

286 |
annotateError owner = |

287 |
flip catchError (throwError . mappend (strMsg $ owner ++ ": ")) |

288 |
{-# INLINE annotateError #-} |

289 | |

290 |
-- | Throws a 'String' message as an error in a 'MonadError'. |

291 |
-- This is a generalization of 'Bad'. |

292 |
-- It's similar to 'fail', but works within a 'MonadError', avoiding the |

293 |
-- unsafe nature of 'fail'. |

294 |
failError :: (MonadError e m, Error e) => String -> m a |

295 |
failError = throwError . strMsg |

296 | |

297 |
-- | A synonym for @flip@ 'catchErrorT'. |

298 |
handleErrorT :: (Monad m, Error e) |

299 |
=> (e' -> ResultT e m a) -> ResultT e' m a -> ResultT e m a |

300 |
handleErrorT handler = elimResultT handler return |

301 |
{-# INLINE handleErrorT #-} |

302 | |

303 |
-- | Catches an error in a @ResultT@ value. This is similar to 'catchError', |

304 |
-- but in addition allows to change the error type. |

305 |
catchErrorT :: (Monad m, Error e) |

306 |
=> ResultT e' m a -> (e' -> ResultT e m a) -> ResultT e m a |

307 |
catchErrorT = flip handleErrorT |

308 |
{-# INLINE catchErrorT #-} |

309 | |

310 |
-- | Iterate while Ok. |

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

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

313 | |

314 |
-- * Misc functionality |

315 | |

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

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

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

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

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

321 | |

322 |
-- | Apply a function to the first element of a list, return the default |

323 |
-- value, if the list is empty. This is just a convenient combination of |

324 |
-- maybe and listToMaybe. |

325 |
runListHead :: a -> (b -> a) -> [b] -> a |

326 |
runListHead a f = maybe a f . listToMaybe |

327 | |

328 |
-- * Lookup of partial names functionality |

329 | |

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

331 |
data MatchPriority = ExactMatch |

332 |
| MultipleMatch |

333 |
| PartialMatch |

334 |
| FailMatch |

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

336 | |

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

338 |
data LookupResult = LookupResult |

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

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

341 |
, lrContent :: String |

342 |
} deriving (Show) |

343 | |

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

345 |
instance Eq LookupResult where |

346 |
(==) = (==) `on` lrMatchPriority |

347 | |

348 |
instance Ord LookupResult where |

349 |
compare = compare `on` lrMatchPriority |

350 | |

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

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

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

354 |
prefixMatch :: String -- ^ Lookup |

355 |
-> String -- ^ Full name |

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

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

358 | |

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

360 |
goodMatchPriority :: MatchPriority -> Bool |

361 |
goodMatchPriority ExactMatch = True |

362 |
goodMatchPriority PartialMatch = True |

363 |
goodMatchPriority _ = False |

364 | |

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

366 |
goodLookupResult :: LookupResult -> Bool |

367 |
goodLookupResult = goodMatchPriority . lrMatchPriority |

368 | |

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

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

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

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

373 |
compareNameComponent cnl lkp = |

374 |
select (LookupResult FailMatch lkp) |

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

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

377 |
] |

378 | |

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

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

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

382 |
-> LookupResult -- ^ Previous result |

383 |
-> LookupResult -- ^ New result |

384 |
chooseLookupResult lkp cstr old = |

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

386 |
select (min new old) |

387 |
-- special cases: |

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

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

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

391 |
, (partial2, LookupResult MultipleMatch lkp) |

392 |
] where new = compareNameComponent cstr lkp |

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

394 | |

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

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

397 |
-> String -- ^ Lookup string |

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

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

400 |
(LookupResult FailMatch s) l |

401 | |

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

403 |
-- |

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

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

406 |
-- without duplicate elements. |

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

408 |
deriving (Eq, Show) |

409 | |

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

411 |
showJSON = JSON.showJSON . unListSet |

412 |
readJSON = liftM ListSet . JSON.readJSON |

413 | |

414 |
emptyListSet :: ListSet a |

415 |
emptyListSet = ListSet Set.empty |