Revision 0b7bf465 src/Ganeti/THH.hs
| b/src/Ganeti/THH.hs | ||
|---|---|---|
| 10 | 10 |
|
| 11 | 11 |
{-
|
| 12 | 12 |
|
| 13 |
Copyright (C) 2011, 2012, 2013 Google Inc. |
|
| 13 |
Copyright (C) 2011, 2012, 2013, 2014 Google Inc.
|
|
| 14 | 14 |
|
| 15 | 15 |
This program is free software; you can redistribute it and/or modify |
| 16 | 16 |
it under the terms of the GNU General Public License as published by |
| ... | ... | |
| 155 | 155 |
numericalReadFn _ _ _ = JSON.Error "A numerical field has to be a number or\ |
| 156 | 156 |
\ a string." |
| 157 | 157 |
|
| 158 |
-- | Wrapper to lift a read function to optional values |
|
| 159 |
makeReadOptional :: ([(String, JSON.JSValue)] -> JSON.JSValue -> JSON.Result a) |
|
| 160 |
-> [(String, JSON.JSValue)] |
|
| 161 |
-> Maybe JSON.JSValue -> JSON.Result (Maybe a) |
|
| 162 |
makeReadOptional _ _ Nothing = JSON.Ok Nothing |
|
| 163 |
makeReadOptional f o (Just x) = fmap Just $ f o x |
|
| 164 |
|
|
| 165 | 158 |
-- | Sets the read function to also accept string parsable by the given |
| 166 | 159 |
-- function. |
| 167 | 160 |
specialNumericalField :: Name -> Field -> Field |
| 168 | 161 |
specialNumericalField f field = |
| 169 |
if (fieldIsOptional field == NotOptional) |
|
| 170 |
then field { fieldRead = Just (appE (varE 'numericalReadFn) (varE f)) }
|
|
| 171 |
else field { fieldRead = Just (appE (varE 'makeReadOptional)
|
|
| 172 |
(appE (varE 'numericalReadFn) |
|
| 173 |
(varE f))) } |
|
| 162 |
field { fieldRead = Just (appE (varE 'numericalReadFn) (varE f)) }
|
|
| 174 | 163 |
|
| 175 | 164 |
-- | Sets custom functions on a field. |
| 176 | 165 |
customField :: Name -- ^ The name of the read function |
| ... | ... | |
| 219 | 208 |
fail $ "Default field " ++ name ++ " used in parameter declaration" |
| 220 | 209 |
checkNonOptDef _ = return () |
| 221 | 210 |
|
| 211 |
-- | Construct a function that parses a field value. If the field has |
|
| 212 |
-- a custom 'fieldRead', it's applied to @o@ and used. Otherwise |
|
| 213 |
-- @JSON.readJSON@ is used. |
|
| 214 |
parseFn :: Field -- ^ The field definition |
|
| 215 |
-> Q Exp -- ^ The entire object in JSON object format |
|
| 216 |
-> Q Exp -- ^ The resulting function that parses a JSON message |
|
| 217 |
parseFn field o = maybe [| JSON.readJSON |] (`appE` o) (fieldRead field) |
|
| 218 |
|
|
| 222 | 219 |
-- | Produces the expression that will de-serialise a given |
| 223 | 220 |
-- field. Since some custom parsing functions might need to use the |
| 224 | 221 |
-- entire object, we do take and pass the object to any custom read |
| ... | ... | |
| 227 | 224 |
-> Q Exp -- ^ The value of the field as existing in the JSON message |
| 228 | 225 |
-> Q Exp -- ^ The entire object in JSON object format |
| 229 | 226 |
-> Q Exp -- ^ Resulting expression |
| 230 |
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
|
|
| 231 |
loadFn _ expr _ = expr |
|
| 227 |
loadFn field expr o = [| $expr >>= $(parseFn field o) |] |
|
| 228 |
|
|
| 229 |
-- | Just as 'loadFn', but for optional fields. |
|
| 230 |
loadFnOpt :: Field -- ^ The field definition |
|
| 231 |
-> Q Exp -- ^ The value of the field as existing in the JSON message |
|
| 232 |
-- as Maybe |
|
| 233 |
-> Q Exp -- ^ The entire object in JSON object format |
|
| 234 |
-> Q Exp -- ^ Resulting expression |
|
| 235 |
loadFnOpt field@(Field { fieldDefault = Just def }) expr o
|
|
| 236 |
= [| $expr >>= maybe (return $def) $(parseFn field o) |] |
|
| 237 |
loadFnOpt field expr o |
|
| 238 |
= [| $expr >>= maybe (return Nothing) (liftM Just . $(parseFn field o)) |] |
|
| 232 | 239 |
|
| 233 | 240 |
-- * Common field declarations |
| 234 | 241 |
|
| ... | ... | |
| 962 | 969 |
-- these are used in all patterns below |
| 963 | 970 |
let objvar = varNameE "o" |
| 964 | 971 |
objfield = stringE (fieldName field) |
| 965 |
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 |
Just defv -> |
|
| 973 |
[| $(varE 'fromObjWithDefault) $objvar |
|
| 974 |
$objfield $defv |] |
|
| 975 |
Nothing -> [| $fromObjE $objvar $objfield |] |
|
| 976 |
bexp <- loadFn field loadexp objvar |
|
| 972 |
bexp <- case fieldDefault field of |
|
| 973 |
-- Only non-optional fields without defaults must have a value; |
|
| 974 |
-- we treat both optional types the same, since |
|
| 975 |
-- 'maybeFromObj' can deal with both missing and null values |
|
| 976 |
-- appropriately (the same) |
|
| 977 |
Nothing | fieldIsOptional field == NotOptional -> |
|
| 978 |
loadFn field [| fromObj $objvar $objfield |] objvar |
|
| 979 |
_ -> loadFnOpt field [| maybeFromObj $objvar $objfield |] objvar |
|
| 977 | 980 |
|
| 978 | 981 |
return (fvar, BindS (VarP fvar) bexp) |
| 979 | 982 |
|
| ... | ... | |
| 1079 | 1082 |
let objvar = varNameE "o" |
| 1080 | 1083 |
objfield = stringE name |
| 1081 | 1084 |
loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |] |
| 1082 |
field' = field {fieldRead=fmap (appE (varE 'makeReadOptional))
|
|
| 1083 |
$ fieldRead field} |
|
| 1084 |
bexp <- loadFn field' loadexp objvar |
|
| 1085 |
bexp <- loadFnOpt field loadexp objvar |
|
| 1085 | 1086 |
return (fvar, BindS (VarP fvar) bexp) |
| 1086 | 1087 |
|
| 1087 | 1088 |
-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@. |
Also available in: Unified diff