Revision c2442429 src/Ganeti/THH.hs
b/src/Ganeti/THH.hs | ||
---|---|---|
73 | 73 |
import Data.Char |
74 | 74 |
import Data.List |
75 | 75 |
import Data.Maybe |
76 |
import qualified Data.Map as M |
|
76 | 77 |
import qualified Data.Set as Set |
77 | 78 |
import Language.Haskell.TH |
78 | 79 |
|
... | ... | |
96 | 97 |
= NotOptional -- ^ Field is not optional |
97 | 98 |
| OptionalOmitNull -- ^ Field is optional, null is not serialised |
98 | 99 |
| OptionalSerializeNull -- ^ Field is optional, null is serialised |
100 |
| AndRestArguments -- ^ Special field capturing all the remaining fields |
|
101 |
-- as plain JSON values |
|
99 | 102 |
deriving (Show, Eq) |
100 | 103 |
|
101 | 104 |
-- | Serialised field data type. |
... | ... | |
202 | 205 |
-- | Compute the actual field type (taking into account possible |
203 | 206 |
-- optional status). |
204 | 207 |
actualFieldType :: Field -> Q Type |
205 |
actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |]
|
|
206 |
| otherwise = t
|
|
208 |
actualFieldType f | fieldIsOptional f `elem` [NotOptional, AndRestArguments] = t
|
|
209 |
| otherwise = [t| Maybe $t |]
|
|
207 | 210 |
where t = fieldType f |
208 | 211 |
|
209 | 212 |
-- | Checks that a given field is not optional (for object types or |
... | ... | |
763 | 766 |
loadConstructor :: OpCodeConstructor -> Q Exp |
764 | 767 |
loadConstructor (sname, _, _, fields, _) = do |
765 | 768 |
let name = mkName sname |
766 |
fbinds <- mapM loadObjectField fields
|
|
769 |
fbinds <- mapM (loadObjectField fields) fields
|
|
767 | 770 |
let (fnames, fstmts) = unzip fbinds |
768 | 771 |
let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames |
769 | 772 |
fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)] |
... | ... | |
866 | 869 |
buildObjectSerialisation sname fields = do |
867 | 870 |
let name = mkName sname |
868 | 871 |
savedecls <- genSaveObject saveObjectField sname fields |
869 |
(loadsig, loadfn) <- genLoadObject loadObjectField sname fields
|
|
872 |
(loadsig, loadfn) <- genLoadObject (loadObjectField fields) sname fields
|
|
870 | 873 |
shjson <- objectShowJSON sname |
871 | 874 |
rdjson <- objectReadJSON sname |
872 | 875 |
let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) |
... | ... | |
921 | 924 |
Just fn -> [| let (actual, extra) = $fn $fvarE |
922 | 925 |
in ($nameE, JSON.showJSON actual):extra |
923 | 926 |
|] |
927 |
AndRestArguments -> [| M.toList $(varE fvar) |] |
|
924 | 928 |
where nameE = stringE (fieldName field) |
925 | 929 |
fvarE = varE fvar |
926 | 930 |
|
... | ... | |
955 | 959 |
FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []]) |
956 | 960 |
|
957 | 961 |
-- | Generates code for loading an object's field. |
958 |
loadObjectField :: Field -> Q (Name, Stmt) |
|
959 |
loadObjectField field = do |
|
962 |
loadObjectField :: [Field] -> Field -> Q (Name, Stmt)
|
|
963 |
loadObjectField allFields field = do
|
|
960 | 964 |
let name = fieldVariable field |
965 |
names = map fieldVariable allFields |
|
966 |
otherNames = listE . map stringE $ names \\ [name] |
|
961 | 967 |
fvar <- newName name |
962 | 968 |
-- these are used in all patterns below |
963 | 969 |
let objvar = varNameE "o" |
964 | 970 |
objfield = stringE (fieldName field) |
965 | 971 |
loadexp = |
966 |
if fieldIsOptional field /= NotOptional |
|
967 |
-- we treat both optional types the same, since |
|
968 |
-- 'maybeFromObj' can deal with both missing and null values |
|
969 |
-- appropriately (the same) |
|
970 |
then [| $(varE 'maybeFromObj) $objvar $objfield |] |
|
971 |
else case fieldDefault field of |
|
972 |
case fieldIsOptional field of |
|
973 |
NotOptional -> |
|
974 |
case fieldDefault field of |
|
972 | 975 |
Just defv -> |
973 | 976 |
[| $(varE 'fromObjWithDefault) $objvar |
974 | 977 |
$objfield $defv |] |
975 | 978 |
Nothing -> [| $fromObjE $objvar $objfield |] |
979 |
AndRestArguments -> [| return . M.fromList |
|
980 |
$ filter (not . (`elem` $otherNames) . fst) |
|
981 |
$objvar |] |
|
982 |
_ -> [| $(varE 'maybeFromObj) $objvar $objfield |] |
|
983 |
-- we treat both optional types the same, since |
|
984 |
-- 'maybeFromObj' can deal with both missing and null values |
|
985 |
-- appropriately (the same) |
|
976 | 986 |
bexp <- loadFn field loadexp objvar |
977 | 987 |
|
978 | 988 |
return (fvar, BindS (VarP fvar) bexp) |
Also available in: Unified diff