Add tagSingleConstructors option

Author: Lysxia

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/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:

tests/UnitTests.hs

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