Revision 58b37916 src/Ganeti/THH.hs
b/src/Ganeti/THH.hs | ||
---|---|---|
1007 | 1007 |
objVarName :: Name |
1008 | 1008 |
objVarName = mkName "_o" |
1009 | 1009 |
|
1010 |
-- | The toDict function name for a given type. |
|
1011 |
toDictName :: String -> Name |
|
1012 |
toDictName sname = mkName ("toDict" ++ sname) |
|
1013 |
|
|
1014 |
-- | The fromDict function name for a given type. |
|
1015 |
fromDictName :: String -> Name |
|
1016 |
fromDictName sname = mkName ("fromDict" ++ sname) |
|
1017 |
|
|
1018 | 1010 |
-- | Generates 'DictObject' instance. |
1019 | 1011 |
genDictObject :: (Name -> Field -> Q Exp) -- ^ a saving function |
1020 | 1012 |
-> (Field -> Q Exp) -- ^ a loading function |
... | ... | |
1031 | 1023 |
-- fromDict |
1032 | 1024 |
fdexp <- loadConstructor name load_fn fields |
1033 | 1025 |
let fdclause = Clause [VarP objVarName] (NormalB fdexp) [] |
1034 |
-- the toDict... function |
|
1035 |
let tdname = toDictName sname |
|
1036 |
tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |] |
|
1037 | 1026 |
-- the final instance |
1038 |
return $ [InstanceD [] (AppT (ConT ''DictObject) (ConT name)) |
|
1039 |
[ ValD (VarP 'toDict) (NormalB (VarE tdname)) [] |
|
1040 |
, FunD 'fromDict [fdclause] |
|
1041 |
]] ++ |
|
1042 |
[ SigD tdname tdsigt |
|
1043 |
, ValD (VarP tdname) (NormalB (VarE 'toDict)) [] ] |
|
1027 |
return [InstanceD [] (AppT (ConT ''DictObject) (ConT name)) |
|
1028 |
[ FunD 'toDict [tdclause] |
|
1029 |
, FunD 'fromDict [fdclause] |
|
1030 |
]] |
|
1044 | 1031 |
|
1045 | 1032 |
-- | Generates the save object functionality. |
1046 | 1033 |
genSaveObject :: String -> Q [Dec] |
... | ... | |
1165 | 1152 |
val = ListE $ map (LitE . StringL . fieldName) fields |
1166 | 1153 |
in [sig, ValD (VarP vname) (NormalB val) []] |
1167 | 1154 |
|
1168 |
-- | Builds the 'DictObject' instance for a filled parameter. |
|
1169 |
buildDictObjectInst :: Name -> String -> [Dec] |
|
1170 |
buildDictObjectInst name sname = |
|
1171 |
[InstanceD [] (AppT (ConT ''DictObject) (ConT name)) |
|
1172 |
[ ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) [] |
|
1173 |
, ValD (VarP 'fromDict) (NormalB (VarE (fromDictName sname))) [] |
|
1174 |
]] |
|
1175 |
|
|
1176 | 1155 |
-- | Generates the serialisation for a partial parameter. |
1177 | 1156 |
buildPParamSerialisation :: String -> [Field] -> Q [Dec] |
1178 | 1157 |
buildPParamSerialisation sname fields = do |
Also available in: Unified diff