Revision 92678b3c htools/Ganeti/THH.hs
| b/htools/Ganeti/THH.hs | ||
|---|---|---|
| 29 | 29 |
|
| 30 | 30 |
-} |
| 31 | 31 |
|
| 32 |
module Ganeti.THH ( declareSADT |
|
| 32 |
module Ganeti.THH ( Store(..) |
|
| 33 |
, declareSADT |
|
| 33 | 34 |
, makeJSONInstance |
| 34 | 35 |
, genOpID |
| 35 | 36 |
, genOpCode |
| ... | ... | |
| 428 | 429 |
-- | LuxiOp parameter type. |
| 429 | 430 |
type LuxiParam = (String, Q Type, Q Exp) |
| 430 | 431 |
|
| 432 |
-- | Storage options for JSON. |
|
| 433 |
data Store = SList | SDict |
|
| 434 |
|
|
| 431 | 435 |
-- | Generates the LuxiOp data type. |
| 432 | 436 |
-- |
| 433 | 437 |
-- This takes a Luxi operation definition and builds both the |
| ... | ... | |
| 444 | 448 |
-- * operation; this is the operation performed on the parameter before |
| 445 | 449 |
-- serialization |
| 446 | 450 |
-- |
| 447 |
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec] |
|
| 451 |
genLuxiOp :: String -> [(String, [LuxiParam], Store)] -> Q [Dec]
|
|
| 448 | 452 |
genLuxiOp name cons = do |
| 449 |
decl_d <- mapM (\(cname, fields) -> do |
|
| 453 |
decl_d <- mapM (\(cname, fields, _) -> do
|
|
| 450 | 454 |
fields' <- mapM (\(_, qt, _) -> |
| 451 | 455 |
qt >>= \t -> return (NotStrict, t)) |
| 452 | 456 |
fields |
| ... | ... | |
| 456 | 460 |
(savesig, savefn) <- genSaveLuxiOp cons |
| 457 | 461 |
return [declD, savesig, savefn] |
| 458 | 462 |
|
| 463 |
-- | Generates a Q Exp for an element, depending of the JSON return type. |
|
| 464 |
helperLuxiField :: Store -> String -> Q Exp -> Q Exp |
|
| 465 |
helperLuxiField SList name val = [| [ JSON.showJSON $val ] |] |
|
| 466 |
helperLuxiField SDict name val = [| [(name, JSON.showJSON $val)] |] |
|
| 467 |
|
|
| 468 |
-- | Generates the \"save\" expression for a single luxi parameter. |
|
| 469 |
saveLuxiField :: Store -> Name -> LuxiParam -> Q Exp |
|
| 470 |
saveLuxiField store fvar (fname, qt, fn) = do |
|
| 471 |
t <- qt |
|
| 472 |
let fvare = varE fvar |
|
| 473 |
(if isOptional t |
|
| 474 |
then [| case $fvare of |
|
| 475 |
Just v' -> |
|
| 476 |
$(helperLuxiField store fname $ liftM2 appFn fn [| v' |]) |
|
| 477 |
Nothing -> [] |
|
| 478 |
|] |
|
| 479 |
else helperLuxiField store fname $ liftM2 appFn fn fvare) |
|
| 480 |
|
|
| 481 |
-- | Generates final JSON Q Exp for constructor. |
|
| 482 |
helperLuxiConstructor :: Store -> Q Exp -> Q Exp |
|
| 483 |
helperLuxiConstructor SDict val = [| JSON.showJSON $ JSON.makeObj $val |] |
|
| 484 |
helperLuxiConstructor SList val = [| JSON.JSArray $val |] |
|
| 485 |
|
|
| 459 | 486 |
-- | Generates the \"save\" clause for entire LuxiOp constructor. |
| 460 |
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause |
|
| 461 |
saveLuxiConstructor (sname, fields) =
|
|
| 487 |
saveLuxiConstructor :: (String, [LuxiParam], Store) -> Q Clause
|
|
| 488 |
saveLuxiConstructor (sname, fields, store) = do
|
|
| 462 | 489 |
let cname = mkName sname |
| 463 | 490 |
fnames = map (\(nm, _, _) -> mkName nm) fields |
| 464 | 491 |
pat = conP cname (map varP fnames) |
| 465 |
flist = map (\(nm, _, fn) -> liftM2 appFn fn $ (varNameE nm)) fields |
|
| 466 |
showlist = map (\x -> [| JSON.showJSON $x |]) flist |
|
| 467 |
finval = case showlist of |
|
| 468 |
[] -> [| JSON.showJSON () |] |
|
| 469 |
_ -> [| JSON.showJSON $(listE showlist) |] |
|
| 470 |
in clause [pat] (normalB finval) [] |
|
| 492 |
flist = map (uncurry $ saveLuxiField store) (zip fnames fields) |
|
| 493 |
flist' = appE [| concat |] (listE flist) |
|
| 494 |
finval = helperLuxiConstructor store flist' |
|
| 495 |
clause [pat] (normalB finval) [] |
|
| 471 | 496 |
|
| 472 | 497 |
-- | Generates the main save LuxiOp function. |
| 473 |
genSaveLuxiOp :: [(String, [LuxiParam])] -> Q (Dec, Dec)
|
|
| 498 |
genSaveLuxiOp :: [(String, [LuxiParam], Store)]-> Q (Dec, Dec)
|
|
| 474 | 499 |
genSaveLuxiOp opdefs = do |
| 475 | 500 |
sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |] |
| 476 | 501 |
let fname = mkName "opToArgs" |
Also available in: Unified diff