Implement tagSingleConstructors for Generics

haskell · Apr 3, 2017 · 3392b6d · 3392b6d
1 parent 235d387
commit 3392b6d
Show file tree

Hide file tree

Showing 2 changed files with 38 additions and 13 deletions.
diff --git a/Data/Aeson/Types/FromJSON.hs b/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{..} ->

diff --git a/Data/Aeson/Types/ToJSON.hs b/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':