git.iko.soy/typeable/aeson
on master help sign in
Add the omitNothingFields encoding option
2d12b02Bas van Dijk
Data/Aeson/TH.hs+42−13
compare with master
unifiedsplit
@@ -97,9 +97,9 @@ import Data.Functor ( fmap )
97import Data.Int ( Int )
97import Data.Int ( Int )
98import Data.Either ( Either(Left, Right) )
98import Data.Either ( Either(Left, Right) )
99import Data.List ( (++), foldl, foldl', intercalate
99import Data.List ( (++), foldl, foldl', intercalate
100− , length, map, zip, genericLength, all
100+ , length, map, zip, genericLength, all, partition
101 )
101 )
102−import Data.Maybe ( Maybe(Nothing, Just) )
102+import Data.Maybe ( Maybe(Nothing, Just), catMaybes )
103import Prelude ( String, (-), Integer, fromIntegral, error )
103import Prelude ( String, (-), Integer, fromIntegral, error )
104import Text.Printf ( printf )
104import Text.Printf ( printf )
105import Text.Show ( show )
105import Text.Show ( show )
@@ -287,23 +287,52 @@ encodeArgs opts multiCons (NormalC conName ts) = do
287-- Records.
287-- Records.
288encodeArgs opts multiCons (RecC conName ts) = do
288encodeArgs opts multiCons (RecC conName ts) = do
289 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
289 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
290+ let exp = [|object|] `appE` pairs
291+
292+ pairs | omitNothingFields opts = infixApp maybeFields
293+ [|(++)|]
294+ restFields
295+ | otherwise = listE $ map toPair argCons
296+
297+ argCons = zip args ts
298+
299+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
300+
301+ restFields = listE $ map toPair rest
302+
303+ (maybes, rest) = partition isMaybe argCons
304+
305+ isMaybe (_, (_, _, AppT (ConT t) _)) = t == ''Maybe
306+ isMaybe _ = False
307+
308+ maybeToPair (arg, (field, _, _)) =
309+ infixApp (infixE (Just $ toFieldName field)
310+ [|(.=)|]
311+ Nothing)
312+ [|(<$>)|]
313+ (varE arg)
314+
315+ toPair (arg, (field, _, _)) =
316+ infixApp (toFieldName field)
317+ [|(.=)|]
318+ (varE arg)
319+
290− let js = [ infixApp ([|T.pack|] `appE` fieldNameExp opts field)
320+ toFieldName field = [|T.pack|] `appE` fieldNameExp opts field
291− [|(.=)|]
321+
292− (varE arg)
293− | (arg, (field, _, _)) <- zip args ts
294− ]
295− exp = [|object|] `appE` listE js
296 match (conP conName $ map varP args)
322 match (conP conName $ map varP args)
297 ( normalB
323 ( normalB
298 $ if multiCons
324 $ if multiCons
299 then case sumEncoding opts of
325 then case sumEncoding opts of
300 TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
326 TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
301 ObjectWithType{typeFieldName} ->
327 ObjectWithType{typeFieldName} ->
302− [|object|] `appE` listE
328+ [|object|] `appE`
329+ -- TODO: Maybe throw an error in case
330+ -- typeFieldName overwrites a field in pairs.
303− ( infixApp [|T.pack typeFieldName|] [|(.=)|]
331+ infixApp (infixApp [|T.pack typeFieldName|]
332+ [|(.=)|]
304− (conStr opts conName)
333+ (conStr opts conName))
305− : js
334+ [|(:)|]
306− )
335+ pairs
307 ObjectWithSingleField ->
336 ObjectWithSingleField ->
308 [|object|] `appE` listE
337 [|object|] `appE` listE
309 [ infixApp (conTxt opts conName) [|(.=)|] exp ]
338 [ infixApp (conTxt opts conName) [|(.=)|] exp ]
Data/Aeson/Types/Generic.hs+9−1
@@ -23,7 +23,7 @@ import Control.Monad.ST (ST)
23import Data.Aeson.Types.Class
23import Data.Aeson.Types.Class
24import Data.Aeson.Types.Internal
24import Data.Aeson.Types.Internal
25import Data.Bits (shiftR)
25import Data.Bits (shiftR)
26−import Data.DList (DList, toList)
26+import Data.DList (DList, toList, empty)
27import Data.Monoid (mappend)
27import Data.Monoid (mappend)
28import Data.Text (Text, pack, unpack)
28import Data.Text (Text, pack, unpack)
29import GHC.Generics
29import GHC.Generics
@@ -198,6 +198,14 @@ instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
198 )
198 )
199 {-# INLINE gRecordToPairs #-}
199 {-# INLINE gRecordToPairs #-}
200
200
201+instance (Selector s, ToJSON a) => GRecordToPairs (S1 s (K1 i (Maybe a))) where
202+ gRecordToPairs opts (M1 k1) | omitNothingFields opts
203+ , K1 Nothing <- k1 = empty
204+ gRecordToPairs opts m1 = pure ( pack $ fieldNameModifier opts $ selName m1
205+ , gToJSON opts (unM1 m1)
206+ )
207+ {-# INLINE gRecordToPairs #-}
208+
201--------------------------------------------------------------------------------
209--------------------------------------------------------------------------------
202
210
203class GProductToValues f where
211class GProductToValues f where
Data/Aeson/Types/Internal.hs+19−7
@@ -249,7 +249,7 @@ modifyFailure f (Parser p) = Parser $ \kf -> p (kf . f)
249-- Generic and TH encoding configuration
249-- Generic and TH encoding configuration
250--------------------------------------------------------------------------------
250--------------------------------------------------------------------------------
251
251
252−-- | Options that specify how to encode your datatype to JSON.
252+-- | Options that specify how to encode/decode your datatype to/from JSON.
253data Options = Options
253data Options = Options
254 { fieldNameModifier :: String -> String
254 { fieldNameModifier :: String -> String
255 -- ^ Function applied to field names.
255 -- ^ Function applied to field names.
@@ -258,10 +258,14 @@ data Options = Options
258 -- ^ Function applied to constructor names.
258 -- ^ Function applied to constructor names.
259 -- Handy for lower-casing constructor names for example.
259 -- Handy for lower-casing constructor names for example.
260 , nullaryToString :: Bool
260 , nullaryToString :: Bool
261− -- ^ If 'True' the constructors of a datatypes, with all nullary
261+ -- ^ If 'True' the constructors of a datatype, with all nullary
262 -- constructors, will be encoded to a string with the
262 -- constructors, will be encoded to a string with the
263 -- constructor name. If 'False' the encoding will always follow
263 -- constructor name. If 'False' the encoding will always follow
264 -- the `sumEncoding`.
264 -- the `sumEncoding`.
265+ , omitNothingFields :: Bool
266+ -- ^ If 'True' record fields with a 'Nothing' value will be
267+ -- omitted from the resulting object. If 'False' the resulting
268+ -- object will include those fields with @null@ values.
265 , sumEncoding :: SumEncoding
269 , sumEncoding :: SumEncoding
266 -- ^ Specifies how to encode constructors of a sum datatype.
270 -- ^ Specifies how to encode constructors of a sum datatype.
267 }
271 }
@@ -287,19 +291,27 @@ data SumEncoding =
287 -- 'constructorNameModifier') and the value will be the contents
291 -- 'constructorNameModifier') and the value will be the contents
288 -- of the constructor.
292 -- of the constructor.
289
293
290−-- | Default encoding options which specify to not modify field and
294+-- | Default encoding 'Options':
291−-- constructor names, encode the constructors of a datatype with all
295+--
292−-- nullary constructors to just strings with the name of the
296+-- @
293−-- constructor and use a 2-element array for other sum datatypes.
297+-- 'Options'
298+-- { 'fieldNameModifier' = id
299+-- , 'constructorNameModifier' = id
300+-- , 'nullaryToString' = True
301+-- , 'omitNothingFields' = True
302+-- , 'sumEncoding' = 'TwoElemArray'
303+-- }
304+-- @
294defaultOptions :: Options
305defaultOptions :: Options
295defaultOptions = Options
306defaultOptions = Options
296 { fieldNameModifier = id
307 { fieldNameModifier = id
297 , constructorNameModifier = id
308 , constructorNameModifier = id
298 , nullaryToString = True
309 , nullaryToString = True
310+ , omitNothingFields = True
299 , sumEncoding = TwoElemArray
311 , sumEncoding = TwoElemArray
300 }
312 }
301
313
302−-- | Note that:
314+-- | Default 'ObjectWithType' 'SumEncoding' options:
303--
315--
304-- @
316-- @
305-- defaultObjectWithType = 'ObjectWithType'
317-- defaultObjectWithType = 'ObjectWithType'