Merge pull request #522 from Lysxia/feature-473

Option to encode single-constructor types as tagged sums

Author: bergmark

Data/Aeson/TH.hs

@@ -341,7 +341,7 @@ consToValue jc opts cons = do
     matches tjs = case cons of
       -- A single constructor is directly encoded. The constructor itself may be
       -- forgotten.
-      [con] -> [argsToValue jc tjs opts False con]
+      [con] | not (tagSingleConstructors opts) -> [argsToValue jc tjs opts False con]
       _ | allNullaryToStringTag opts && all isNullary cons ->
               [ match (conP conName []) (normalB $ conStr opts conName) []
               | con <- cons
@@ -384,7 +384,7 @@ consToEncoding jc opts cons = do
     matches tes = case cons of
       -- A single constructor is directly encoded. The constructor itself may be
       -- forgotten.
-      [con] -> [argsToEncoding jc tes opts False con]
+      [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tes opts False con]
       -- Encode just the name of the constructor of a sum type iff all the
       -- constructors are nullary.
       _ | allNullaryToStringTag opts && all isNullary cons ->
@@ -792,7 +792,9 @@ consFromJSON jc tName opts cons = do
 
   where
     lamExpr value pjs = case cons of
-      [con] -> parseArgs jc pjs tName opts con (Right value)
+      [con]
+        | not (tagSingleConstructors opts)
+            -> parseArgs jc pjs tName opts con (Right value)
       _ | sumEncoding opts == UntaggedValue
             -> parseUntaggedValue pjs cons value
         | otherwise

Data/Aeson/Types/FromJSON.hs

@@ -791,6 +791,19 @@ instance GFromJSON arity U1 where
         | isEmptyArray v = pure U1
         | otherwise      = typeMismatch "unit constructor (U1)" v
 
+instance ( ConsFromJSON arity a
+         , AllNullary         (C1 c a) allNullary
+         , ParseSum     arity (C1 c a) allNullary
+         ) => GFromJSON arity (D1 d (C1 c a)) where
+    -- The option 'tagSingleConstructors' determines whether to wrap
+    -- a single-constructor type.
+    gParseJSON opts fargs
+        | tagSingleConstructors opts
+            = fmap M1
+            . (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))
+            . parseSum opts fargs
+        | otherwise = fmap M1 . fmap M1 . consParseJSON opts fargs
+
 instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where
     -- Constructors need to be decoded differently depending on whether they're
     -- a record or not. This distinction is made by consParseJSON:
@@ -837,19 +850,19 @@ class ParseSum arity f allNullary where
     parseSum :: Options -> FromArgs arity a
              -> Value -> Tagged allNullary (Parser (f a))
 
-instance ( SumFromString           (a :+: b)
-         , FromPair          arity (a :+: b)
-         , FromTaggedObject  arity (a :+: b)
-         , FromUntaggedValue arity (a :+: b)
-         ) => ParseSum       arity (a :+: b) True where
+instance ( SumFromString           f
+         , FromPair          arity f
+         , FromTaggedObject  arity f
+         , FromUntaggedValue arity f
+         ) => ParseSum       arity f True where
     parseSum opts fargs
         | allNullaryToStringTag opts = Tagged . parseAllNullarySum    opts
         | otherwise                  = Tagged . parseNonAllNullarySum opts fargs
 
-instance ( FromPair          arity (a :+: b)
-         , FromTaggedObject  arity (a :+: b)
-         , FromUntaggedValue arity (a :+: b)
-         ) => ParseSum       arity (a :+: b) False where
+instance ( FromPair          arity f
+         , FromTaggedObject  arity f
+         , FromUntaggedValue arity f
+         ) => ParseSum       arity f False where
     parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs
 
 --------------------------------------------------------------------------------
@@ -875,11 +888,11 @@ instance (Constructor c) => SumFromString (C1 c U1) where
 
 --------------------------------------------------------------------------------
 
-parseNonAllNullarySum :: ( FromPair          arity (a :+: b)
-                         , FromTaggedObject  arity (a :+: b)
-                         , FromUntaggedValue arity (a :+: b)
+parseNonAllNullarySum :: ( FromPair          arity f
+                         , FromTaggedObject  arity f
+                         , FromUntaggedValue arity f
                          ) => Options -> FromArgs arity c
-                           -> Value -> Parser ((a :+: b) c)
+                           -> Value -> Parser (f c)
 parseNonAllNullarySum opts fargs =
     case sumEncoding opts of
       TaggedObject{..} ->

Data/Aeson/Types/Internal.hs

@@ -524,10 +524,13 @@ data Options = Options
     , unwrapUnaryRecords :: Bool
       -- ^ Hide the field name when a record constructor has only one
       -- field, like a newtype.
+    , tagSingleConstructors :: Bool
+      -- ^ Encode types with a single constructor as sums,
+      -- so that `allNullaryToStringTag` and `sumEncoding` apply.
     }
 
 instance Show Options where
-  show (Options f c a o s u) =
+  show (Options f c a o s u t) =
        "Options {"
     ++ intercalate ", "
       [ "fieldLabelModifier =~ " ++ show (f "exampleField")
@@ -536,6 +539,7 @@ instance Show Options where
       , "omitNothingFields = " ++ show o
       , "sumEncoding = " ++ show s
       , "unwrapUnaryRecords = " ++ show u
+      , "tagSingleConstructors = " ++ show t
       ]
     ++ "}"
 
@@ -589,6 +593,7 @@ data SumEncoding =
 -- , 'omitNothingFields'       = False
 -- , 'sumEncoding'             = 'defaultTaggedObject'
 -- , 'unwrapUnaryRecords'      = False
+-- , 'tagSingleConstructors'   = False
 -- }
 -- @
 defaultOptions :: Options
@@ -599,6 +604,7 @@ defaultOptions = Options
                  , omitNothingFields       = False
                  , sumEncoding             = defaultTaggedObject
                  , unwrapUnaryRecords      = False
+                 , tagSingleConstructors   = False
                  }
 
 -- | Default 'TaggedObject' 'SumEncoding' options:

Data/Aeson/Types/ToJSON.hs

@@ -659,6 +659,18 @@ instance GToJSON enc One Par1 where
     -- function passed in as an argument:
     gToJSON _opts (To1Args tj _) = tj . unPar1
 
+instance ( ConsToJSON enc arity a
+         , AllNullary          (C1 c a) allNullary
+         , SumToJSON enc arity (C1 c a) allNullary
+         ) => GToJSON enc arity (D1 d (C1 c a)) where
+    -- The option 'tagSingleConstructors' determines whether to wrap
+    -- a single-constructor type.
+    gToJSON opts targs
+        | tagSingleConstructors opts = (unTagged :: Tagged allNullary enc -> enc)
+                                     . sumToJSON opts targs
+                                     . unM1
+        | otherwise = consToJSON opts targs . unM1 . unM1
+
 instance (ConsToJSON enc arity a) => GToJSON enc arity (C1 c a) where
     -- Constructors need to be encoded differently depending on whether they're
     -- a record or not. This distinction is made by 'consToJSON':

tests/Encoders.hs

@@ -354,3 +354,31 @@ thOneConstructorToEncodingDefault = $(mkToEncoding defaultOptions ''OneConstruct
 
 thOneConstructorParseJSONDefault :: Value -> Parser OneConstructor
 thOneConstructorParseJSONDefault = $(mkParseJSON defaultOptions ''OneConstructor)
+
+thOneConstructorToJSONTagged :: OneConstructor -> Value
+thOneConstructorToJSONTagged = $(mkToJSON optsTagSingleConstructors ''OneConstructor)
+
+thOneConstructorToEncodingTagged :: OneConstructor -> Encoding
+thOneConstructorToEncodingTagged = $(mkToEncoding optsTagSingleConstructors ''OneConstructor)
+
+thOneConstructorParseJSONTagged :: Value -> Parser OneConstructor
+thOneConstructorParseJSONTagged = $(mkParseJSON optsTagSingleConstructors ''OneConstructor)
+
+
+gOneConstructorToJSONDefault :: OneConstructor -> Value
+gOneConstructorToJSONDefault = genericToJSON defaultOptions
+
+gOneConstructorToEncodingDefault :: OneConstructor -> Encoding
+gOneConstructorToEncodingDefault = genericToEncoding defaultOptions
+
+gOneConstructorParseJSONDefault :: Value -> Parser OneConstructor
+gOneConstructorParseJSONDefault = genericParseJSON defaultOptions
+
+gOneConstructorToJSONTagged :: OneConstructor -> Value
+gOneConstructorToJSONTagged = genericToJSON optsTagSingleConstructors
+
+gOneConstructorToEncodingTagged :: OneConstructor -> Encoding
+gOneConstructorToEncodingTagged = genericToEncoding optsTagSingleConstructors
+
+gOneConstructorParseJSONTagged :: Value -> Parser OneConstructor
+gOneConstructorParseJSONTagged = genericParseJSON optsTagSingleConstructors

tests/Options.hs

@@ -42,3 +42,9 @@ optsUntaggedValue :: Options
 optsUntaggedValue = optsDefault
     { sumEncoding = UntaggedValue
     }
+
+optsTagSingleConstructors :: Options
+optsTagSingleConstructors = optsDefault
+                            { tagSingleConstructors = True
+                            , allNullaryToStringTag = False
+                            }

tests/Properties.hs

@@ -168,11 +168,14 @@ isTaggedObjectValue (Object obj) = "tag"      `H.member` obj &&
 isTaggedObjectValue _            = False
 
 isNullaryTaggedObject :: Value -> Bool
-isNullaryTaggedObject obj = isTaggedObject obj && isObjectWithSingleField obj
+isNullaryTaggedObject obj = isTaggedObject' obj && isObjectWithSingleField obj
 
-isTaggedObject :: Value -> Bool
-isTaggedObject (Object obj) = "tag" `H.member` obj
-isTaggedObject _            = False
+isTaggedObject :: Value -> Property
+isTaggedObject = checkValue isTaggedObject'
+
+isTaggedObject' :: Value -> Bool
+isTaggedObject' (Object obj) = "tag" `H.member` obj
+isTaggedObject' _            = False
 
 isObjectWithSingleField :: Value -> Bool
 isObjectWithSingleField (Object obj) = H.size obj == 1
@@ -338,6 +341,14 @@ tests = testGroup "properties" [
 #endif
           ]
         ]
+      , testGroup "OneConstructor" [
+          testProperty "default" (isEmptyArray . gOneConstructorToJSONDefault)
+        , testProperty "Tagged"  (isTaggedObject . gOneConstructorToJSONTagged)
+        , testGroup "roundTrip" [
+            testProperty "default" (toParseJSON gOneConstructorParseJSONDefault gOneConstructorToJSONDefault)
+          , testProperty "Tagged"  (toParseJSON gOneConstructorParseJSONTagged  gOneConstructorToJSONTagged)
+          ]
+        ]
       ]
     , testGroup "toEncoding" [
         testProperty "NullaryString" $
@@ -386,6 +397,11 @@ tests = testGroup "properties" [
 
       , testProperty "SomeTypeOmitNothingFields" $
         gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields
+
+      , testProperty "OneConstructorDefault" $
+        gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault
+      , testProperty "OneConstructorTagged" $
+        gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged
       ]
     ]
   , testGroup "template-haskell" [
@@ -440,8 +456,10 @@ tests = testGroup "properties" [
         ]
       , testGroup "OneConstructor" [
           testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)
+        , testProperty "Tagged"  (isTaggedObject . thOneConstructorToJSONTagged)
         , testGroup "roundTrip" [
             testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)
+          , testProperty "Tagged"  (toParseJSON thOneConstructorParseJSONTagged  thOneConstructorToJSONTagged)
           ]
         ]
       ]
@@ -484,8 +502,10 @@ tests = testGroup "properties" [
       , testProperty "SomeTypeObjectWithSingleField unary agree" $
         thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField
 
-      , testProperty "OneConstructor" $
+      , testProperty "OneConstructorDefault" $
         thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault
+      , testProperty "OneConstructorTagged" $
+        thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged
       ]
     ]
   ]

tests/UnitTests.hs

@@ -494,6 +494,7 @@ showOptions =
         ++ ", omitNothingFields = False"
         ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
         ++ ", unwrapUnaryRecords = False"
+        ++ ", tagSingleConstructors = False"
         ++ "}")
         (show defaultOptions)