git.iko.soy/typeable/aeson
on master help sign in
Add the omitNothingFields encoding option
commit2d12b0208b1b78a495a03d23db314793f36d1003 authorBas van Dijk <v.dijk.bas@gmail.com> dateThu 11 Apr 2013, 20:07 (14 years ago) parent8e4b5be
3 files changed+70−21
compare with master
unifiedsplit
Data/Aeson/TH.hs+42−13 Data/Aeson/Types/Generic.hs+9−1 Data/Aeson/Types/Internal.hs+19−7
Data/Aeson/TH.hs+42−13
@@ -97,9 +97,9 @@ import Data.Functor ( fmap )
9797import Data.Int ( Int )
9898import Data.Either ( Either(Left, Right) )
9999import Data.List ( (++), foldl, foldl', intercalate
100− , length, map, zip, genericLength, all
100+ , length, map, zip, genericLength, all, partition
101101 )
102−import Data.Maybe ( Maybe(Nothing, Just) )
102+import Data.Maybe ( Maybe(Nothing, Just), catMaybes )
103103import Prelude ( String, (-), Integer, fromIntegral, error )
104104import Text.Printf ( printf )
105105import Text.Show ( show )
@@ -287,23 +287,52 @@ encodeArgs opts multiCons (NormalC conName ts) = do
287287-- Records.
288288encodeArgs opts multiCons (RecC conName ts) = do
289289 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
290− let js = [ infixApp ([|T.pack|] `appE` fieldNameExp opts field)
291− [|(.=)|]
292− (varE arg)
293− | (arg, (field, _, _)) <- zip args ts
294− ]
295− exp = [|object|] `appE` listE js
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+
320+ toFieldName field = [|T.pack|] `appE` fieldNameExp opts field
321+
296322 match (conP conName $ map varP args)
297323 ( normalB
298324 $ if multiCons
299325 then case sumEncoding opts of
300326 TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
301327 ObjectWithType{typeFieldName} ->
302− [|object|] `appE` listE
303− ( infixApp [|T.pack typeFieldName|] [|(.=)|]
304− (conStr opts conName)
305− : js
306− )
328+ [|object|] `appE`
329+ -- TODO: Maybe throw an error in case
330+ -- typeFieldName overwrites a field in pairs.
331+ infixApp (infixApp [|T.pack typeFieldName|]
332+ [|(.=)|]
333+ (conStr opts conName))
334+ [|(:)|]
335+ pairs
307336 ObjectWithSingleField ->
308337 [|object|] `appE` listE
309338 [ infixApp (conTxt opts conName) [|(.=)|] exp ]
Data/Aeson/Types/Generic.hs+9−1
@@ -23,7 +23,7 @@ import Control.Monad.ST (ST)
2323import Data.Aeson.Types.Class
2424import Data.Aeson.Types.Internal
2525import Data.Bits (shiftR)
26−import Data.DList (DList, toList)
26+import Data.DList (DList, toList, empty)
2727import Data.Monoid (mappend)
2828import Data.Text (Text, pack, unpack)
2929import GHC.Generics
@@ -198,6 +198,14 @@ instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
198198 )
199199 {-# INLINE gRecordToPairs #-}
200200
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+
201209--------------------------------------------------------------------------------
202210
203211class GProductToValues f where
Data/Aeson/Types/Internal.hs+19−7
@@ -249,7 +249,7 @@ modifyFailure f (Parser p) = Parser $ \kf -> p (kf . f)
249249-- Generic and TH encoding configuration
250250--------------------------------------------------------------------------------
251251
252−-- | Options that specify how to encode your datatype to JSON.
252+-- | Options that specify how to encode/decode your datatype to/from JSON.
253253data Options = Options
254254 { fieldNameModifier :: String -> String
255255 -- ^ Function applied to field names.
@@ -258,10 +258,14 @@ data Options = Options
258258 -- ^ Function applied to constructor names.
259259 -- Handy for lower-casing constructor names for example.
260260 , nullaryToString :: Bool
261− -- ^ If 'True' the constructors of a datatypes, with all nullary
261+ -- ^ If 'True' the constructors of a datatype, with all nullary
262262 -- constructors, will be encoded to a string with the
263263 -- constructor name. If 'False' the encoding will always follow
264264 -- 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.
265269 , sumEncoding :: SumEncoding
266270 -- ^ Specifies how to encode constructors of a sum datatype.
267271 }
@@ -287,19 +291,27 @@ data SumEncoding =
287291 -- 'constructorNameModifier') and the value will be the contents
288292 -- of the constructor.
289293
290−-- | Default encoding options which specify to not modify field and
291−-- constructor names, encode the constructors of a datatype with all
292−-- nullary constructors to just strings with the name of the
293−-- constructor and use a 2-element array for other sum datatypes.
294+-- | Default encoding 'Options':
295+--
296+-- @
297+-- 'Options'
298+-- { 'fieldNameModifier' = id
299+-- , 'constructorNameModifier' = id
300+-- , 'nullaryToString' = True
301+-- , 'omitNothingFields' = True
302+-- , 'sumEncoding' = 'TwoElemArray'
303+-- }
304+-- @
294305defaultOptions :: Options
295306defaultOptions = Options
296307 { fieldNameModifier = id
297308 , constructorNameModifier = id
298309 , nullaryToString = True
310+ , omitNothingFields = True
299311 , sumEncoding = TwoElemArray
300312 }
301313
302−-- | Note that:
314+-- | Default 'ObjectWithType' 'SumEncoding' options:
303315--
304316-- @
305317-- defaultObjectWithType = 'ObjectWithType'