Revision 185b5b0d
| b/htools/Ganeti/THH.hs | ||
|---|---|---|
| 236 | 236 |
appFn f x | f == VarE 'id = x |
| 237 | 237 |
| otherwise = AppE f x |
| 238 | 238 |
|
| 239 |
-- | Builds a field for a normal constructor. |
|
| 240 |
buildConsField :: Q Type -> StrictTypeQ |
|
| 241 |
buildConsField ftype = do |
|
| 242 |
ftype' <- ftype |
|
| 243 |
return (NotStrict, ftype') |
|
| 244 |
|
|
| 245 |
-- | Builds a constructor based on a simple definition (not field-based). |
|
| 246 |
buildSimpleCons :: Name -> SimpleObject -> Q Dec |
|
| 247 |
buildSimpleCons tname cons = do |
|
| 248 |
decl_d <- mapM (\(cname, fields) -> do |
|
| 249 |
fields' <- mapM (buildConsField . snd) fields |
|
| 250 |
return $ NormalC (mkName cname) fields') cons |
|
| 251 |
return $ DataD [] tname [] decl_d [''Show, ''Read, ''Eq] |
|
| 252 |
|
|
| 253 |
-- | Generate the save function for a given type. |
|
| 254 |
genSaveSimpleObj :: Name -- ^ Object type |
|
| 255 |
-> String -- ^ Function name |
|
| 256 |
-> SimpleObject -- ^ Object definition |
|
| 257 |
-> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn |
|
| 258 |
-> Q (Dec, Dec) |
|
| 259 |
genSaveSimpleObj tname sname opdefs fn = do |
|
| 260 |
let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue) |
|
| 261 |
fname = mkName sname |
|
| 262 |
cclauses <- mapM fn opdefs |
|
| 263 |
return $ (SigD fname sigt, FunD fname cclauses) |
|
| 264 |
|
|
| 239 | 265 |
-- * Template code for simple raw type-equivalent ADTs |
| 240 | 266 |
|
| 241 | 267 |
-- | Generates a data type declaration. |
| ... | ... | |
| 573 | 599 |
-- |
| 574 | 600 |
genLuxiOp :: String -> SimpleObject -> Q [Dec] |
| 575 | 601 |
genLuxiOp name cons = do |
| 576 |
decl_d <- mapM (\(cname, fields) -> do |
|
| 577 |
fields' <- mapM (\(_, qt) -> |
|
| 578 |
qt >>= \t -> return (NotStrict, t)) |
|
| 579 |
fields |
|
| 580 |
return $ NormalC (mkName cname) fields') |
|
| 581 |
cons |
|
| 582 |
let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] |
|
| 583 |
(savesig, savefn) <- genSaveLuxiOp cons |
|
| 602 |
let tname = mkName name |
|
| 603 |
declD <- buildSimpleCons tname cons |
|
| 604 |
(savesig, savefn) <- genSaveSimpleObj tname "opToArgs" |
|
| 605 |
cons saveLuxiConstructor |
|
| 584 | 606 |
req_defs <- declareSADT "LuxiReq" . |
| 585 | 607 |
map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
|
| 586 | 608 |
cons |
| ... | ... | |
| 603 | 625 |
else [| JSON.showJSON $(listE flist) |] |
| 604 | 626 |
clause [pat] (normalB finval) [] |
| 605 | 627 |
|
| 606 |
-- | Generates the main save LuxiOp function. |
|
| 607 |
genSaveLuxiOp :: SimpleObject-> Q (Dec, Dec) |
|
| 608 |
genSaveLuxiOp opdefs = do |
|
| 609 |
sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |] |
|
| 610 |
let fname = mkName "opToArgs" |
|
| 611 |
cclauses <- mapM saveLuxiConstructor opdefs |
|
| 612 |
return $ (SigD fname sigt, FunD fname cclauses) |
|
| 613 |
|
|
| 614 | 628 |
-- * "Objects" functionality |
| 615 | 629 |
|
| 616 | 630 |
-- | Extract the field's declaration from a Field structure. |
Also available in: Unified diff