Revision 12c19659 htools/Ganeti/THH.hs
b/htools/Ganeti/THH.hs | ||
---|---|---|
32 | 32 |
module Ganeti.THH ( declareSADT |
33 | 33 |
, makeJSONInstance |
34 | 34 |
, genOpID |
35 |
, genOpCode |
|
36 |
, noDefault |
|
35 | 37 |
) where |
36 | 38 |
|
37 | 39 |
import Control.Monad (liftM) |
... | ... | |
224 | 226 |
cnames <- mapM (liftM nameBase . constructorName) cons |
225 | 227 |
let svalues = map (Left . deCamelCase) cnames |
226 | 228 |
genToString (mkName fname) name $ zip cnames svalues |
229 |
|
|
230 |
|
|
231 |
-- | OpCode parameter (field) type |
|
232 |
type OpParam = (String, Q Type, Q Exp) |
|
233 |
|
|
234 |
-- | Generates the OpCode data type. |
|
235 |
-- |
|
236 |
-- This takes an opcode logical definition, and builds both the |
|
237 |
-- datatype and the JSON serialisation out of it. We can't use a |
|
238 |
-- generic serialisation since we need to be compatible with Ganeti's |
|
239 |
-- own, so we have a few quirks to work around. |
|
240 |
-- |
|
241 |
-- There are three things to be defined for each parameter: |
|
242 |
-- |
|
243 |
-- * name |
|
244 |
-- |
|
245 |
-- * type; if this is 'Maybe', will only be serialised if it's a |
|
246 |
-- 'Just' value |
|
247 |
-- |
|
248 |
-- * default; if missing, won't raise an exception, but will instead |
|
249 |
-- use the default |
|
250 |
-- |
|
251 |
genOpCode :: String -- ^ Type name to use |
|
252 |
-> [(String, [OpParam])] -- ^ Constructor name and parameters |
|
253 |
-> Q [Dec] |
|
254 |
genOpCode name cons = do |
|
255 |
decl_d <- mapM (\(cname, fields) -> do |
|
256 |
-- we only need the type of the field, without Q |
|
257 |
fields' <- mapM (\(_, qt, _) -> |
|
258 |
qt >>= \t -> return (NotStrict, t)) |
|
259 |
fields |
|
260 |
return $ NormalC (mkName cname) fields') |
|
261 |
cons |
|
262 |
let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] |
|
263 |
|
|
264 |
(savesig, savefn) <- genSaveOpCode cons |
|
265 |
(loadsig, loadfn) <- genLoadOpCode cons |
|
266 |
return [declD, loadsig, loadfn, savesig, savefn] |
|
267 |
|
|
268 |
-- | Checks whether a given parameter is options |
|
269 |
-- |
|
270 |
-- This requires that it's a 'Maybe'. |
|
271 |
isOptional :: Type -> Bool |
|
272 |
isOptional (AppT (ConT dt) _) | dt == ''Maybe = True |
|
273 |
isOptional _ = False |
|
274 |
|
|
275 |
-- | Generates the \"save\" expression for a single opcode parameter. |
|
276 |
-- |
|
277 |
-- There is only one special handling mode: if the parameter is of |
|
278 |
-- 'Maybe' type, then we only save it if it's a 'Just' value, |
|
279 |
-- otherwise we skip it. |
|
280 |
saveField :: Name -- ^ The name of variable that contains the value |
|
281 |
-> OpParam -- ^ Parameter definition |
|
282 |
-> Q Exp |
|
283 |
saveField fvar (fname, qt, _) = do |
|
284 |
t <- qt |
|
285 |
let showJ = varE (mkName "showJSON") |
|
286 |
fnexp = litE (stringL fname) |
|
287 |
fvare = varE fvar |
|
288 |
(if isOptional t |
|
289 |
then [| case $fvare of |
|
290 |
Just v' -> [( $fnexp, $showJ v')] |
|
291 |
Nothing -> [] |
|
292 |
|] |
|
293 |
else [| [( $fnexp, $showJ $fvare )] |]) |
|
294 |
|
|
295 |
-- | Generates the \"save\" clause for an entire opcode constructor. |
|
296 |
-- |
|
297 |
-- This matches the opcode with variables named the same as the |
|
298 |
-- constructor fields (just so that the spliced in code looks nicer), |
|
299 |
-- and passes those name plus the parameter definition to 'saveField'. |
|
300 |
saveConstructor :: String -- ^ The constructor name |
|
301 |
-> [OpParam] -- ^ The parameter definitions for this |
|
302 |
-- constructor |
|
303 |
-> Q Clause -- ^ Resulting clause |
|
304 |
saveConstructor sname fields = do |
|
305 |
let cname = mkName sname |
|
306 |
let fnames = map (\(n, _, _) -> mkName n) fields |
|
307 |
let pat = conP cname (map varP fnames) |
|
308 |
let felems = map (uncurry saveField) (zip fnames fields) |
|
309 |
-- now build the OP_ID serialisation |
|
310 |
opid = [| [( $(litE (stringL "OP_ID")), |
|
311 |
$(varE (mkName "showJSON")) |
|
312 |
$(litE . stringL . deCamelCase $ sname) )] |] |
|
313 |
flist = listE (opid:felems) |
|
314 |
-- and finally convert all this to a json object |
|
315 |
flist' = [| $(varE (mkName "makeObj")) (concat $flist) |] |
|
316 |
clause [pat] (normalB flist') [] |
|
317 |
|
|
318 |
-- | Generates the main save opcode function. |
|
319 |
-- |
|
320 |
-- This builds a per-constructor match clause that contains the |
|
321 |
-- respective constructor-serialisation code. |
|
322 |
genSaveOpCode :: [(String, [OpParam])] -> Q (Dec, Dec) |
|
323 |
genSaveOpCode opdefs = do |
|
324 |
cclauses <- mapM (uncurry saveConstructor) opdefs |
|
325 |
let fname = mkName "saveOpCode" |
|
326 |
sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |] |
|
327 |
return $ (SigD fname sigt, FunD fname cclauses) |
|
328 |
|
|
329 |
-- | Generates the \"load\" field for a single parameter. |
|
330 |
-- |
|
331 |
-- There is custom handling, depending on how the parameter is |
|
332 |
-- specified. For a 'Maybe' type parameter, we allow that it is not |
|
333 |
-- present (via 'Utils.maybeFromObj'). Otherwise, if there is a |
|
334 |
-- default value, we allow the parameter to be abset, and finally if |
|
335 |
-- there is no default value, we require its presence. |
|
336 |
loadField :: OpParam -> Q (Name, Stmt) |
|
337 |
loadField (fname, qt, qdefa) = do |
|
338 |
let fvar = mkName fname |
|
339 |
t <- qt |
|
340 |
defa <- qdefa |
|
341 |
-- these are used in all patterns below |
|
342 |
let objvar = varE (mkName "o") |
|
343 |
objfield = litE (StringL fname) |
|
344 |
bexp <- if isOptional t |
|
345 |
then [| $((varE (mkName "maybeFromObj"))) $objvar $objfield |] |
|
346 |
else case defa of |
|
347 |
AppE (ConE dt) defval | dt == 'Just -> |
|
348 |
-- but has a default value |
|
349 |
[| $(varE (mkName "fromObjWithDefault")) |
|
350 |
$objvar $objfield $(return defval) |] |
|
351 |
ConE dt | dt == 'Nothing -> |
|
352 |
[| $(varE (mkName "fromObj")) $objvar $objfield |] |
|
353 |
s -> fail $ "Invalid default value " ++ show s ++ |
|
354 |
", expecting either 'Nothing' or a 'Just defval'" |
|
355 |
return (fvar, BindS (VarP fvar) bexp) |
|
356 |
|
|
357 |
loadConstructor :: String -> [OpParam] -> Q Exp |
|
358 |
loadConstructor sname fields = do |
|
359 |
let name = mkName sname |
|
360 |
fbinds <- mapM loadField fields |
|
361 |
let (fnames, fstmts) = unzip fbinds |
|
362 |
let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames |
|
363 |
fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)] |
|
364 |
return $ DoE fstmts' |
|
365 |
|
|
366 |
genLoadOpCode :: [(String, [OpParam])] -> Q (Dec, Dec) |
|
367 |
genLoadOpCode opdefs = do |
|
368 |
let fname = mkName "loadOpCode" |
|
369 |
arg1 = mkName "v" |
|
370 |
objname = mkName "o" |
|
371 |
opid = mkName "op_id" |
|
372 |
st1 <- bindS (varP objname) [| liftM JSON.fromJSObject |
|
373 |
(JSON.readJSON $(varE arg1)) |] |
|
374 |
st2 <- bindS (varP opid) [| $(varE (mkName "fromObj")) |
|
375 |
$(varE objname) $(litE (stringL "OP_ID")) |] |
|
376 |
-- the match results (per-constructor blocks) |
|
377 |
mexps <- mapM (uncurry loadConstructor) opdefs |
|
378 |
fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |] |
|
379 |
let mpats = map (\(me, c) -> |
|
380 |
let mp = LitP . StringL . deCamelCase . fst $ c |
|
381 |
in Match mp (NormalB me) [] |
|
382 |
) $ zip mexps opdefs |
|
383 |
defmatch = Match WildP (NormalB fails) [] |
|
384 |
cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch] |
|
385 |
body = DoE [st1, st2, cst] |
|
386 |
sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |] |
|
387 |
return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []]) |
|
388 |
|
|
389 |
-- | No default type. |
|
390 |
noDefault :: Q Exp |
|
391 |
noDefault = conE 'Nothing |
Also available in: Unified diff