Extend the Template Haskell loadFn model

Currently, we only allow field-by-field de-serialisation. Since we
have cases where information about how to un-serialise a field is
split across two JSON fields (e.g. disk type and disk logical_id,
hypervisor and hvparams, etc.), we need to pass the entire object to
custom read functions.

Furthermore, since we will have to generate two actual fields from the
single in-memory field, we need to extend the custom save function so
that they can generate additional fields beyond the "main" field value
they currently generate.

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Agata Murawska <agatamurawska@google.com>

diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index b6f134c..929da6f 100644 (file)
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -144,11 +144,18 @@ checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
   fail $ "Default field " ++ name ++ " used in parameter declaration"
 checkNonOptDef _ = return ()
 
-loadFn :: Field -> Q Exp -> Q Exp
-loadFn (Field { fieldIsContainer = True }) expr = [| $expr >>= readContainer |]
-loadFn (Field { fieldRead = Just readfn }) expr = [| $expr >>= $readfn |]
-loadFn _ expr = expr
-
+-- | Produces the expression that will de-serialise a given
+-- field. Since some custom parsing functions might need to use the
+-- entire object, we do take and pass the object to any custom read
+-- functions.
+loadFn :: Field   -- ^ The field definition
+       -> Q Exp   -- ^ The value of the field as existing in the JSON message
+       -> Q Exp   -- ^ The entire object in JSON object format
+       -> Q Exp   -- ^ Resulting expression
+loadFn (Field { fieldIsContainer = True }) expr _ =
+  [| $expr >>= readContainer |]
+loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
+loadFn _ expr _ = expr
 
 -- * Common field declarations
 
@@ -632,7 +639,9 @@ saveObjectField fvar field
                   |]
   | otherwise = case fieldShow field of
       Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
-      Just fn -> [| [( $nameE, JSON.showJSON . $fn $ $fvarE)] |]
+      Just fn -> [| let (actual, extra) = $fn $fvarE
+                    in extra ++ [( $nameE, JSON.showJSON actual)]
+                  |]
   where isContainer = fieldIsContainer field
         fisOptional  = fieldIsOptional field
         nameE = stringE (fieldName field)
@@ -676,7 +685,7 @@ loadObjectField field = do
                    [| $(varNameE "fromObjWithDefault") $objvar
                       $objfield $defv |]
                  Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
-  bexp <- loadFn field loadexp
+  bexp <- loadFn field loadexp objvar
 
   return (fvar, BindS (VarP fvar) bexp)
 
@@ -761,7 +770,7 @@ loadPParamField field = do
   let objvar = varNameE "o"
       objfield = stringE name
       loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
-  bexp <- loadFn field loadexp
+  bexp <- loadFn field loadexp objvar
   return (fvar, BindS (VarP fvar) bexp)
 
 -- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.