Revision e45be9d4
b/htools/Ganeti/THH.hs | ||
---|---|---|
222 | 222 |
-- | A definition for ADTs with simple fields. |
223 | 223 |
type SimpleObject = [SimpleConstructor] |
224 | 224 |
|
225 |
-- | A type alias for a constructor of a regular object. |
|
226 |
type Constructor = (String, [Field]) |
|
227 |
|
|
225 | 228 |
-- * Helper functions |
226 | 229 |
|
227 | 230 |
-- | Ensure first letter is lowercase. |
... | ... | |
523 | 526 |
-- datatype and the JSON serialisation out of it. We can't use a |
524 | 527 |
-- generic serialisation since we need to be compatible with Ganeti's |
525 | 528 |
-- own, so we have a few quirks to work around. |
526 |
genOpCode :: String -- ^ Type name to use
|
|
527 |
-> [(String, [Field])] -- ^ Constructor name and parameters
|
|
529 |
genOpCode :: String -- ^ Type name to use |
|
530 |
-> [Constructor] -- ^ Constructor name and parameters
|
|
528 | 531 |
-> Q [Dec] |
529 | 532 |
genOpCode name cons = do |
530 | 533 |
let tname = mkName name |
... | ... | |
543 | 546 |
|
544 | 547 |
-- | Generates the function pattern returning the list of fields for a |
545 | 548 |
-- given constructor. |
546 |
genOpConsFields :: (String, [Field]) -> Clause
|
|
549 |
genOpConsFields :: Constructor -> Clause
|
|
547 | 550 |
genOpConsFields (cname, fields) = |
548 | 551 |
let op_id = deCamelCase cname |
549 | 552 |
fvals = map (LitE . StringL) . sort . nub $ |
... | ... | |
551 | 554 |
in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) [] |
552 | 555 |
|
553 | 556 |
-- | Generates a list of all fields of an opcode constructor. |
554 |
genAllOpFields :: String -- ^ Function name
|
|
555 |
-> [(String, [Field])] -- ^ Object definition
|
|
557 |
genAllOpFields :: String -- ^ Function name |
|
558 |
-> [Constructor] -- ^ Object definition
|
|
556 | 559 |
-> (Dec, Dec) |
557 | 560 |
genAllOpFields sname opdefs = |
558 | 561 |
let cclauses = map genOpConsFields opdefs |
... | ... | |
587 | 590 |
-- |
588 | 591 |
-- This builds a per-constructor match clause that contains the |
589 | 592 |
-- respective constructor-serialisation code. |
590 |
genSaveOpCode :: Name -- ^ Object ype
|
|
591 |
-> String -- ^ Function name
|
|
592 |
-> [(String, [Field])] -- ^ Object definition
|
|
593 |
-> ((String, [Field]) -> Q Clause) -- ^ Constructor save fn
|
|
593 |
genSaveOpCode :: Name -- ^ Object ype |
|
594 |
-> String -- ^ Function name |
|
595 |
-> [Constructor] -- ^ Object definition
|
|
596 |
-> (Constructor -> Q Clause) -- ^ Constructor save fn
|
|
594 | 597 |
-> Q (Dec, Dec) |
595 | 598 |
genSaveOpCode tname sname opdefs fn = do |
596 | 599 |
cclauses <- mapM fn opdefs |
... | ... | |
609 | 612 |
return $ DoE fstmts' |
610 | 613 |
|
611 | 614 |
-- | Generates the loadOpCode function. |
612 |
genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
|
|
615 |
genLoadOpCode :: [Constructor] -> Q (Dec, Dec)
|
|
613 | 616 |
genLoadOpCode opdefs = do |
614 | 617 |
let fname = mkName "loadOpCode" |
615 | 618 |
arg1 = mkName "v" |
... | ... | |
654 | 657 |
-- |
655 | 658 |
-- * type |
656 | 659 |
-- |
657 |
genLuxiOp :: String -> [(String, [Field])] -> Q [Dec]
|
|
660 |
genLuxiOp :: String -> [Constructor] -> Q [Dec]
|
|
658 | 661 |
genLuxiOp name cons = do |
659 | 662 |
let tname = mkName name |
660 | 663 |
decl_d <- mapM (\(cname, fields) -> do |
... | ... | |
677 | 680 |
[| JSON.showJSON $(varE fvar) |] |
678 | 681 |
|
679 | 682 |
-- | Generates the \"save\" clause for entire LuxiOp constructor. |
680 |
saveLuxiConstructor :: (String, [Field]) -> Q Clause
|
|
683 |
saveLuxiConstructor :: Constructor -> Q Clause
|
|
681 | 684 |
saveLuxiConstructor (sname, fields) = do |
682 | 685 |
let cname = mkName sname |
683 | 686 |
fnames <- mapM (newName . fieldVariable) fields |
Also available in: Unified diff