Revision 879273e3
b/htools/Ganeti/THH.hs | ||
---|---|---|
38 | 38 |
, genStrOfOp |
39 | 39 |
, genStrOfKey |
40 | 40 |
, genLuxiOp |
41 |
, Field |
|
42 |
, simpleField |
|
43 |
, defaultField |
|
44 |
, optionalField |
|
45 |
, renameField |
|
46 |
, containerField |
|
47 |
, customField |
|
48 |
, timeStampFields |
|
49 |
, uuidFields |
|
50 |
, serialFields |
|
51 |
, buildObject |
|
52 |
, buildObjectSerialisation |
|
53 |
, buildParam |
|
54 |
, Container |
|
41 | 55 |
) where |
42 | 56 |
|
57 |
import Control.Arrow |
|
43 | 58 |
import Control.Monad (liftM, liftM2) |
44 | 59 |
import Data.Char |
45 | 60 |
import Data.List |
61 |
import qualified Data.Map as M |
|
46 | 62 |
import Language.Haskell.TH |
47 | 63 |
|
48 | 64 |
import qualified Text.JSON as JSON |
49 | 65 |
|
66 |
-- * Exported types |
|
67 |
|
|
68 |
type Container = M.Map String |
|
69 |
|
|
70 |
-- | Serialised field data type. |
|
71 |
data Field = Field { fieldName :: String |
|
72 |
, fieldType :: Q Type |
|
73 |
, fieldRead :: Maybe (Q Exp) |
|
74 |
, fieldShow :: Maybe (Q Exp) |
|
75 |
, fieldDefault :: Maybe (Q Exp) |
|
76 |
, fieldConstr :: Maybe String |
|
77 |
, fieldIsContainer :: Bool |
|
78 |
, fieldIsOptional :: Bool |
|
79 |
} |
|
80 |
|
|
81 |
-- | Generates a simple field. |
|
82 |
simpleField :: String -> Q Type -> Field |
|
83 |
simpleField fname ftype = |
|
84 |
Field { fieldName = fname |
|
85 |
, fieldType = ftype |
|
86 |
, fieldRead = Nothing |
|
87 |
, fieldShow = Nothing |
|
88 |
, fieldDefault = Nothing |
|
89 |
, fieldConstr = Nothing |
|
90 |
, fieldIsContainer = False |
|
91 |
, fieldIsOptional = False |
|
92 |
} |
|
93 |
|
|
94 |
-- | Sets the renamed constructor field. |
|
95 |
renameField :: String -> Field -> Field |
|
96 |
renameField constrName field = field { fieldConstr = Just constrName } |
|
97 |
|
|
98 |
-- | Sets the default value on a field (makes it optional with a |
|
99 |
-- default value). |
|
100 |
defaultField :: Q Exp -> Field -> Field |
|
101 |
defaultField defval field = field { fieldDefault = Just defval } |
|
102 |
|
|
103 |
-- | Marks a field optional (turning its base type into a Maybe). |
|
104 |
optionalField :: Field -> Field |
|
105 |
optionalField field = field { fieldIsOptional = True } |
|
106 |
|
|
107 |
-- | Marks a field as a container. |
|
108 |
containerField :: Field -> Field |
|
109 |
containerField field = field { fieldIsContainer = True } |
|
110 |
|
|
111 |
-- | Sets custom functions on a field. |
|
112 |
customField :: Q Exp -> Q Exp -> Field -> Field |
|
113 |
customField readfn showfn field = |
|
114 |
field { fieldRead = Just readfn, fieldShow = Just showfn } |
|
115 |
|
|
116 |
fieldRecordName :: Field -> String |
|
117 |
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) = |
|
118 |
maybe (camelCase name) id alias |
|
119 |
|
|
120 |
fieldVariable :: Field -> String |
|
121 |
fieldVariable = map toLower . fieldRecordName |
|
122 |
|
|
123 |
actualFieldType :: Field -> Q Type |
|
124 |
actualFieldType f | fieldIsContainer f = [t| Container $t |] |
|
125 |
| fieldIsOptional f = [t| Maybe $t |] |
|
126 |
| otherwise = t |
|
127 |
where t = fieldType f |
|
128 |
|
|
129 |
checkNonOptDef :: (Monad m) => Field -> m () |
|
130 |
checkNonOptDef (Field { fieldIsOptional = True, fieldName = name }) = |
|
131 |
fail $ "Optional field " ++ name ++ " used in parameter declaration" |
|
132 |
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) = |
|
133 |
fail $ "Default field " ++ name ++ " used in parameter declaration" |
|
134 |
checkNonOptDef _ = return () |
|
135 |
|
|
136 |
loadFn :: Field -> Q Exp -> Q Exp |
|
137 |
loadFn (Field { fieldIsContainer = True }) expr = [| $expr >>= readContainer |] |
|
138 |
loadFn (Field { fieldRead = Just readfn }) expr = [| $expr >>= $readfn |] |
|
139 |
loadFn _ expr = expr |
|
140 |
|
|
141 |
saveFn :: Field -> Q Exp -> Q Exp |
|
142 |
saveFn (Field { fieldIsContainer = True }) expr = [| showContainer $expr |] |
|
143 |
saveFn (Field { fieldRead = Just readfn }) expr = [| $readfn $expr |] |
|
144 |
saveFn _ expr = expr |
|
145 |
|
|
146 |
-- * Common field declarations |
|
147 |
|
|
148 |
timeStampFields :: [Field] |
|
149 |
timeStampFields = |
|
150 |
[ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |] |
|
151 |
, defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |] |
|
152 |
] |
|
153 |
|
|
154 |
serialFields :: [Field] |
|
155 |
serialFields = |
|
156 |
[ renameField "Serial" $ simpleField "serial_no" [t| Int |] ] |
|
157 |
|
|
158 |
uuidFields :: [Field] |
|
159 |
uuidFields = [ simpleField "uuid" [t| String |] ] |
|
160 |
|
|
50 | 161 |
-- * Helper functions |
51 | 162 |
|
52 | 163 |
-- | Ensure first letter is lowercase. |
... | ... | |
57 | 168 |
ensureLower [] = [] |
58 | 169 |
ensureLower (x:xs) = toLower x:xs |
59 | 170 |
|
171 |
-- | Ensure first letter is uppercase. |
|
172 |
-- |
|
173 |
-- Used to convert constructor name to component |
|
174 |
ensureUpper :: String -> String |
|
175 |
ensureUpper [] = [] |
|
176 |
ensureUpper (x:xs) = toUpper x:xs |
|
177 |
|
|
60 | 178 |
-- | Helper for quoted expressions. |
61 | 179 |
varNameE :: String -> Q Exp |
62 | 180 |
varNameE = varE . mkName |
... | ... | |
86 | 204 |
appFn f x | f == VarE 'id = x |
87 | 205 |
| otherwise = AppE f x |
88 | 206 |
|
207 |
-- | Container loader |
|
208 |
readContainer :: (Monad m) => JSON.JSObject a -> m (Container a) |
|
209 |
readContainer = return . M.fromList . JSON.fromJSObject |
|
210 |
|
|
211 |
-- | Container dumper |
|
212 |
showContainer :: (JSON.JSON a) => Container a -> JSON.JSValue |
|
213 |
showContainer = JSON.makeObj . map (second JSON.showJSON) . M.toList |
|
214 |
|
|
89 | 215 |
-- * Template code for simple raw type-equivalent ADTs |
90 | 216 |
|
91 | 217 |
-- | Generates a data type declaration. |
... | ... | |
233 | 359 |
deCamelCase = |
234 | 360 |
intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b) |
235 | 361 |
|
362 |
-- | Transform an underscore_name into a CamelCase one. |
|
363 |
camelCase :: String -> String |
|
364 |
camelCase = concatMap (ensureUpper . drop 1) . |
|
365 |
groupBy (\_ b -> b /= '_') . ('_':) |
|
366 |
|
|
236 | 367 |
-- | Computes the name of a given constructor. |
237 | 368 |
constructorName :: Con -> Q Name |
238 | 369 |
constructorName (NormalC name _) = return name |
... | ... | |
486 | 617 |
let fname = mkName "opToArgs" |
487 | 618 |
cclauses <- mapM saveLuxiConstructor opdefs |
488 | 619 |
return $ (SigD fname sigt, FunD fname cclauses) |
620 |
|
|
621 |
-- * "Objects" functionality |
|
622 |
|
|
623 |
-- | Extract the field's declaration from a Field structure. |
|
624 |
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type) |
|
625 |
fieldTypeInfo field_pfx fd = do |
|
626 |
t <- actualFieldType fd |
|
627 |
let n = mkName . (field_pfx ++) . fieldRecordName $ fd |
|
628 |
return (n, NotStrict, t) |
|
629 |
|
|
630 |
-- | Build an object declaration. |
|
631 |
buildObject :: String -> String -> [Field] -> Q [Dec] |
|
632 |
buildObject sname field_pfx fields = do |
|
633 |
let name = mkName sname |
|
634 |
fields_d <- mapM (fieldTypeInfo field_pfx) fields |
|
635 |
let decl_d = RecC name fields_d |
|
636 |
let declD = DataD [] name [] [decl_d] [''Show, ''Read] |
|
637 |
ser_decls <- buildObjectSerialisation sname fields |
|
638 |
return $ declD:ser_decls |
|
639 |
|
|
640 |
buildObjectSerialisation :: String -> [Field] -> Q [Dec] |
|
641 |
buildObjectSerialisation sname fields = do |
|
642 |
let name = mkName sname |
|
643 |
savedecls <- genSaveObject saveObjectField sname fields |
|
644 |
(loadsig, loadfn) <- genLoadObject loadObjectField sname fields |
|
645 |
shjson <- objectShowJSON sname |
|
646 |
rdjson <- objectReadJSON sname |
|
647 |
let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) |
|
648 |
(rdjson:shjson) |
|
649 |
return $ savedecls ++ [loadsig, loadfn, instdecl] |
|
650 |
|
|
651 |
genSaveObject :: (Name -> Field -> Q Exp) |
|
652 |
-> String -> [Field] -> Q [Dec] |
|
653 |
genSaveObject save_fn sname fields = do |
|
654 |
let name = mkName sname |
|
655 |
let fnames = map (mkName . fieldVariable) fields |
|
656 |
let pat = conP name (map varP fnames) |
|
657 |
let tdname = mkName ("toDict" ++ sname) |
|
658 |
tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |] |
|
659 |
|
|
660 |
let felems = map (uncurry save_fn) (zip fnames fields) |
|
661 |
flist = listE felems |
|
662 |
-- and finally convert all this to a json object |
|
663 |
tdlist = [| concat $flist |] |
|
664 |
iname = mkName "i" |
|
665 |
tclause <- clause [pat] (normalB tdlist) [] |
|
666 |
cclause <- [| $(varNameE "makeObj") . $(varE tdname) |] |
|
667 |
let fname = mkName ("save" ++ sname) |
|
668 |
sigt <- [t| $(conT name) -> JSON.JSValue |] |
|
669 |
return [SigD tdname tdsigt, FunD tdname [tclause], |
|
670 |
SigD fname sigt, ValD (VarP fname) (NormalB cclause) []] |
|
671 |
|
|
672 |
saveObjectField :: Name -> Field -> Q Exp |
|
673 |
saveObjectField fvar field |
|
674 |
| isContainer = [| [( $nameE , $showJSONE . showContainer $ $fvarE)] |] |
|
675 |
| fisOptional = [| case $(varE fvar) of |
|
676 |
Nothing -> [] |
|
677 |
Just v -> [( $nameE, $showJSONE v)] |
|
678 |
|] |
|
679 |
| otherwise = case fieldShow field of |
|
680 |
Nothing -> [| [( $nameE, $showJSONE $fvarE)] |] |
|
681 |
Just fn -> [| [( $nameE, $showJSONE . $fn $ $fvarE)] |] |
|
682 |
where isContainer = fieldIsContainer field |
|
683 |
fisOptional = fieldIsOptional field |
|
684 |
nameE = stringE (fieldName field) |
|
685 |
fvarE = varE fvar |
|
686 |
|
|
687 |
objectShowJSON :: String -> Q [Dec] |
|
688 |
objectShowJSON name = |
|
689 |
[d| showJSON = JSON.showJSON . $(varE . mkName $ "save" ++ name) |] |
|
690 |
|
|
691 |
genLoadObject :: (Field -> Q (Name, Stmt)) |
|
692 |
-> String -> [Field] -> Q (Dec, Dec) |
|
693 |
genLoadObject load_fn sname fields = do |
|
694 |
let name = mkName sname |
|
695 |
funname = mkName $ "load" ++ sname |
|
696 |
arg1 = mkName "v" |
|
697 |
objname = mkName "o" |
|
698 |
opid = mkName "op_id" |
|
699 |
st1 <- bindS (varP objname) [| liftM JSON.fromJSObject |
|
700 |
(JSON.readJSON $(varE arg1)) |] |
|
701 |
fbinds <- mapM load_fn fields |
|
702 |
let (fnames, fstmts) = unzip fbinds |
|
703 |
let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames |
|
704 |
fstmts' = st1:fstmts ++ [NoBindS (AppE (VarE 'return) cval)] |
|
705 |
sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |] |
|
706 |
return $ (SigD funname sigt, |
|
707 |
FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []]) |
|
708 |
|
|
709 |
loadObjectField :: Field -> Q (Name, Stmt) |
|
710 |
loadObjectField field = do |
|
711 |
let name = fieldVariable field |
|
712 |
fvar = mkName name |
|
713 |
-- these are used in all patterns below |
|
714 |
let objvar = varNameE "o" |
|
715 |
objfield = stringE (fieldName field) |
|
716 |
loadexp = |
|
717 |
if fieldIsOptional field |
|
718 |
then [| $(varNameE "maybeFromObj") $objvar $objfield |] |
|
719 |
else case fieldDefault field of |
|
720 |
Just defv -> |
|
721 |
[| $(varNameE "fromObjWithDefault") $objvar |
|
722 |
$objfield $defv |] |
|
723 |
Nothing -> [| $(varNameE "fromObj") $objvar $objfield |] |
|
724 |
bexp <- loadFn field loadexp |
|
725 |
|
|
726 |
return (fvar, BindS (VarP fvar) bexp) |
|
727 |
|
|
728 |
objectReadJSON :: String -> Q Dec |
|
729 |
objectReadJSON name = do |
|
730 |
let s = mkName "s" |
|
731 |
body <- [| case JSON.readJSON $(varE s) of |
|
732 |
JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s' |
|
733 |
JSON.Error e -> |
|
734 |
JSON.Error $ "Can't parse value for type " ++ |
|
735 |
$(stringE name) ++ ": " ++ e |
|
736 |
|] |
|
737 |
return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []] |
|
738 |
|
|
739 |
-- * Inheritable parameter tables implementation |
|
740 |
|
|
741 |
-- | Compute parameter type names. |
|
742 |
paramTypeNames :: String -> (String, String) |
|
743 |
paramTypeNames root = ("Filled" ++ root ++ "Params", |
|
744 |
"Partial" ++ root ++ "Params") |
|
745 |
|
|
746 |
-- | Compute information about the type of a parameter field. |
|
747 |
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type) |
|
748 |
paramFieldTypeInfo field_pfx fd = do |
|
749 |
t <- actualFieldType fd |
|
750 |
let n = mkName . (++ "P") . (field_pfx ++) . |
|
751 |
fieldRecordName $ fd |
|
752 |
return (n, NotStrict, AppT (ConT ''Maybe) t) |
|
753 |
|
|
754 |
-- | Build a parameter declaration. |
|
755 |
-- |
|
756 |
-- This function builds two different data structures: a /filled/ one, |
|
757 |
-- in which all fields are required, and a /partial/ one, in which all |
|
758 |
-- fields are optional. Due to the current record syntax issues, the |
|
759 |
-- fields need to be named differrently for the two structures, so the |
|
760 |
-- partial ones get a /P/ suffix. |
|
761 |
buildParam :: String -> String -> [Field] -> Q [Dec] |
|
762 |
buildParam sname field_pfx fields = do |
|
763 |
let (sname_f, sname_p) = paramTypeNames sname |
|
764 |
name_f = mkName sname_f |
|
765 |
name_p = mkName sname_p |
|
766 |
fields_f <- mapM (fieldTypeInfo field_pfx) fields |
|
767 |
fields_p <- mapM (paramFieldTypeInfo field_pfx) fields |
|
768 |
let decl_f = RecC name_f fields_f |
|
769 |
decl_p = RecC name_p fields_p |
|
770 |
let declF = DataD [] name_f [] [decl_f] [''Show, ''Read] |
|
771 |
declP = DataD [] name_p [] [decl_p] [''Show, ''Read] |
|
772 |
ser_decls_f <- buildObjectSerialisation sname_f fields |
|
773 |
ser_decls_p <- buildPParamSerialisation sname_p fields |
|
774 |
fill_decls <- fillParam sname field_pfx fields |
|
775 |
return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls |
|
776 |
|
|
777 |
buildPParamSerialisation :: String -> [Field] -> Q [Dec] |
|
778 |
buildPParamSerialisation sname fields = do |
|
779 |
let name = mkName sname |
|
780 |
savedecls <- genSaveObject savePParamField sname fields |
|
781 |
(loadsig, loadfn) <- genLoadObject loadPParamField sname fields |
|
782 |
shjson <- objectShowJSON sname |
|
783 |
rdjson <- objectReadJSON sname |
|
784 |
let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) |
|
785 |
(rdjson:shjson) |
|
786 |
return $ savedecls ++ [loadsig, loadfn, instdecl] |
|
787 |
|
|
788 |
savePParamField :: Name -> Field -> Q Exp |
|
789 |
savePParamField fvar field = do |
|
790 |
checkNonOptDef field |
|
791 |
let actualVal = mkName "v" |
|
792 |
normalexpr <- saveObjectField actualVal field |
|
793 |
-- we have to construct the block here manually, because we can't |
|
794 |
-- splice-in-splice |
|
795 |
return $ CaseE (VarE fvar) [ Match (ConP 'Nothing []) |
|
796 |
(NormalB (ConE '[])) [] |
|
797 |
, Match (ConP 'Just [VarP actualVal]) |
|
798 |
(NormalB normalexpr) [] |
|
799 |
] |
|
800 |
loadPParamField :: Field -> Q (Name, Stmt) |
|
801 |
loadPParamField field = do |
|
802 |
checkNonOptDef field |
|
803 |
let name = fieldName field |
|
804 |
fvar = mkName name |
|
805 |
-- these are used in all patterns below |
|
806 |
let objvar = varNameE "o" |
|
807 |
objfield = stringE name |
|
808 |
loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |] |
|
809 |
bexp <- loadFn field loadexp |
|
810 |
return (fvar, BindS (VarP fvar) bexp) |
|
811 |
|
|
812 |
-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@. |
|
813 |
buildFromMaybe :: String -> Q Dec |
|
814 |
buildFromMaybe fname = |
|
815 |
valD (varP (mkName $ "n_" ++ fname)) |
|
816 |
(normalB [| $(varNameE "fromMaybe") |
|
817 |
$(varNameE $ "f_" ++ fname) |
|
818 |
$(varNameE $ "p_" ++ fname) |]) [] |
|
819 |
|
|
820 |
fillParam :: String -> String -> [Field] -> Q [Dec] |
|
821 |
fillParam sname field_pfx fields = do |
|
822 |
let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields |
|
823 |
(sname_f, sname_p) = paramTypeNames sname |
|
824 |
oname_f = "fobj" |
|
825 |
oname_p = "pobj" |
|
826 |
name_f = mkName sname_f |
|
827 |
name_p = mkName sname_p |
|
828 |
fun_name = mkName $ "fill" ++ sname ++ "Params" |
|
829 |
le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames)) |
|
830 |
(NormalB . VarE . mkName $ oname_f) [] |
|
831 |
le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames)) |
|
832 |
(NormalB . VarE . mkName $ oname_p) [] |
|
833 |
obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f) |
|
834 |
$ map (mkName . ("n_" ++)) fnames |
|
835 |
le_new <- mapM buildFromMaybe fnames |
|
836 |
funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |] |
|
837 |
let sig = SigD fun_name funt |
|
838 |
fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)] |
|
839 |
(NormalB $ LetE (le_full:le_part:le_new) obj_new) [] |
|
840 |
fun = FunD fun_name [fclause] |
|
841 |
return [sig, fun] |
Also available in: Unified diff