Revision 0b7bf465

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