Commits

basvandijk committed 75321dd

Add the omitNothingFields encoding option

  • Participants
  • Parent commits 8dd94d6

Comments (0)

Files changed (3)

File Data/Aeson/TH.hs

 import Data.Int            ( Int )
 import Data.Either         ( Either(Left, Right) )
 import Data.List           ( (++), foldl, foldl', intercalate
-                           , length, map, zip, genericLength, all
+                           , length, map, zip, genericLength, all, partition
                            )
-import Data.Maybe          ( Maybe(Nothing, Just) )
+import Data.Maybe          ( Maybe(Nothing, Just), catMaybes )
 import Prelude             ( String, (-), Integer, fromIntegral, error )
 import Text.Printf         ( printf )
 import Text.Show           ( show )
 -- Records.
 encodeArgs opts multiCons (RecC conName ts) = do
     args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
-    let js = [ infixApp ([|T.pack|] `appE` fieldNameExp opts field)
-                        [|(.=)|]
-                        (varE arg)
-             | (arg, (field, _, _)) <- zip args ts
-             ]
-        exp = [|object|] `appE` listE js
+    let exp = [|object|] `appE` pairs
+
+        pairs | omitNothingFields opts = infixApp maybeFields
+                                                  [|(++)|]
+                                                  restFields
+              | otherwise = listE $ map toPair argCons
+
+        argCons = zip args ts
+
+        maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
+
+        restFields = listE $ map toPair rest
+
+        (maybes, rest) = partition isMaybe argCons
+
+        isMaybe (_, (_, _, AppT (ConT t) _)) = t == ''Maybe
+        isMaybe _ = False
+
+        maybeToPair (arg, (field, _, _)) =
+            infixApp (infixE (Just $ toFieldName field)
+                             [|(.=)|]
+                             Nothing)
+                     [|(<$>)|]
+                     (varE arg)
+
+        toPair (arg, (field, _, _)) =
+            infixApp (toFieldName field)
+                     [|(.=)|]
+                     (varE arg)
+
+        toFieldName field = [|T.pack|] `appE` fieldNameExp opts field
+
     match (conP conName $ map varP args)
           ( normalB
           $ if multiCons
             then case sumEncoding opts of
                    TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
                    ObjectWithType{typeFieldName} ->
-                       [|object|] `appE` listE
-                         ( infixApp [|T.pack typeFieldName|] [|(.=)|]
-                                    (conStr opts conName)
-                         : js
-                         )
+                       [|object|] `appE`
+                         -- TODO: Maybe throw an error in case
+                         -- typeFieldName overwrites a field in pairs.
+                         infixApp (infixApp [|T.pack typeFieldName|]
+                                            [|(.=)|]
+                                            (conStr opts conName))
+                                  [|(:)|]
+                                  pairs
                    ObjectWithSingleField ->
                        [|object|] `appE` listE
                          [ infixApp (conTxt opts conName) [|(.=)|] exp ]

File Data/Aeson/Types/Generic.hs

 import Data.Aeson.Types.Class
 import Data.Aeson.Types.Internal
 import Data.Bits (shiftR)
-import Data.DList (DList, toList)
+import Data.DList (DList, toList, empty)
 import Data.Monoid (mappend)
 import Data.Text (Text, pack, unpack)
 import GHC.Generics
                                   )
     {-# INLINE gRecordToPairs #-}
 
+instance (Selector s, ToJSON a) => GRecordToPairs (S1 s (K1 i (Maybe a))) where
+    gRecordToPairs opts (M1 k1) | omitNothingFields opts
+                                , K1 Nothing <- k1 = empty
+    gRecordToPairs opts m1 = pure ( pack $ fieldNameModifier opts $ selName m1
+                                  , gToJSON opts (unM1 m1)
+                                  )
+    {-# INLINE gRecordToPairs #-}
+
 --------------------------------------------------------------------------------
 
 class GProductToValues f where

File Data/Aeson/Types/Internal.hs

 -- Generic and TH encoding configuration
 --------------------------------------------------------------------------------
 
--- | Options that specify how to encode your datatype to JSON.
+-- | Options that specify how to encode/decode your datatype to/from JSON.
 data Options = Options
     { fieldNameModifier :: String -> String
       -- ^ Function applied to field names.
       -- ^ Function applied to constructor names.
       -- Handy for lower-casing constructor names for example.
     , nullaryToString   :: Bool
-      -- ^ If 'True' the constructors of a datatypes, with all nullary
+      -- ^ If 'True' the constructors of a datatype, with all nullary
       -- constructors, will be encoded to a string with the
       -- constructor name. If 'False' the encoding will always follow
       -- the `sumEncoding`.
+    , omitNothingFields :: Bool
+      -- ^ If 'True' record fields with a 'Nothing' value will be
+      -- omitted from the resulting object. If 'False' the resulting
+      -- object will include those fields with @null@ values.
     , sumEncoding       :: SumEncoding
       -- ^ Specifies how to encode constructors of a sum datatype.
     }
     -- 'constructorNameModifier') and the value will be the contents
     -- of the constructor.
 
--- | Default encoding options which specify to not modify field and
--- constructor names, encode the constructors of a datatype with all
--- nullary constructors to just strings with the name of the
--- constructor and use a 2-element array for other sum datatypes.
+-- | Default encoding 'Options':
+--
+-- @
+-- 'Options'
+-- { 'fieldNameModifier'       = id
+-- , 'constructorNameModifier' = id
+-- , 'nullaryToString'         = True
+-- , 'omitNothingFields'       = True
+-- , 'sumEncoding'             = 'TwoElemArray'
+-- }
+-- @
 defaultOptions :: Options
 defaultOptions = Options
                  { fieldNameModifier       = id
                  , constructorNameModifier = id
                  , nullaryToString         = True
+                 , omitNothingFields       = True
                  , sumEncoding             = TwoElemArray
                  }
 
--- | Note that:
+-- | Default 'ObjectWithType' 'SumEncoding' options:
 --
 -- @
 -- defaultObjectWithType = 'ObjectWithType'