From 1c7bda0a4e62b20f15d9fed8fd258b8551b3bdb5 Mon Sep 17 00:00:00 2001 From: Iustin Pop Date: Mon, 16 Jul 2012 13:37:09 +0200 Subject: [PATCH] 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 Reviewed-by: Agata Murawska --- htools/Ganeti/THH.hs | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index b6f134c..929da6f 100644 --- 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@. -- 1.7.10.4