Revision 2e202a9b htools/Ganeti/THH.hs
| b/htools/Ganeti/THH.hs | ||
|---|---|---|
| 180 | 180 |
tagsFields = [ defaultField [| Set.empty |] $ |
| 181 | 181 |
simpleField "tags" [t| TagSet |] ] |
| 182 | 182 |
|
| 183 |
-- * Internal types |
|
| 184 |
|
|
| 185 |
-- | A simple field, in constrast to the customisable 'Field' type. |
|
| 186 |
type SimpleField = (String, Q Type) |
|
| 187 |
|
|
| 188 |
-- | A definition for a single constructor for a simple object. |
|
| 189 |
type SimpleConstructor = (String, [SimpleField]) |
|
| 190 |
|
|
| 191 |
-- | A definition for ADTs with simple fields. |
|
| 192 |
type SimpleObject = [SimpleConstructor] |
|
| 193 |
|
|
| 183 | 194 |
-- * Helper functions |
| 184 | 195 |
|
| 185 | 196 |
-- | Ensure first letter is lowercase. |
| ... | ... | |
| 547 | 558 |
genStrOfKey :: Name -> String -> Q [Dec] |
| 548 | 559 |
genStrOfKey = genConstrToStr ensureLower |
| 549 | 560 |
|
| 550 |
-- | LuxiOp parameter type. |
|
| 551 |
type LuxiParam = (String, Q Type) |
|
| 552 |
|
|
| 553 | 561 |
-- | Generates the LuxiOp data type. |
| 554 | 562 |
-- |
| 555 | 563 |
-- This takes a Luxi operation definition and builds both the |
| ... | ... | |
| 563 | 571 |
-- |
| 564 | 572 |
-- * type |
| 565 | 573 |
-- |
| 566 |
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
|
|
| 574 |
genLuxiOp :: String -> SimpleObject -> Q [Dec]
|
|
| 567 | 575 |
genLuxiOp name cons = do |
| 568 | 576 |
decl_d <- mapM (\(cname, fields) -> do |
| 569 | 577 |
fields' <- mapM (\(_, qt) -> |
| ... | ... | |
| 579 | 587 |
return $ [declD, savesig, savefn] ++ req_defs |
| 580 | 588 |
|
| 581 | 589 |
-- | Generates the \"save\" expression for a single luxi parameter. |
| 582 |
saveLuxiField :: Name -> LuxiParam -> Q Exp
|
|
| 590 |
saveLuxiField :: Name -> SimpleField -> Q Exp
|
|
| 583 | 591 |
saveLuxiField fvar (_, qt) = |
| 584 | 592 |
[| JSON.showJSON $(varE fvar) |] |
| 585 | 593 |
|
| 586 | 594 |
-- | Generates the \"save\" clause for entire LuxiOp constructor. |
| 587 |
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
|
|
| 595 |
saveLuxiConstructor :: SimpleConstructor -> Q Clause
|
|
| 588 | 596 |
saveLuxiConstructor (sname, fields) = do |
| 589 | 597 |
let cname = mkName sname |
| 590 | 598 |
fnames = map (mkName . fst) fields |
| ... | ... | |
| 596 | 604 |
clause [pat] (normalB finval) [] |
| 597 | 605 |
|
| 598 | 606 |
-- | Generates the main save LuxiOp function. |
| 599 |
genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec)
|
|
| 607 |
genSaveLuxiOp :: SimpleObject-> Q (Dec, Dec)
|
|
| 600 | 608 |
genSaveLuxiOp opdefs = do |
| 601 | 609 |
sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |] |
| 602 | 610 |
let fname = mkName "opToArgs" |
Also available in: Unified diff