Merge pull request #971 from haskell/pr-950-deriving-empty

Pr 950 deriving empty

Author: phadej

changelog.md

@@ -1,5 +1,11 @@
 For the latest version of this document, please see [https://github.com/haskell/aeson/blob/master/changelog.md](https://github.com/haskell/aeson/blob/master/changelog.md).
 
+### 2.1.2.0
+
+* Support deriving for empty datatypes (such as `Void` and `V1`)
+  in `FromJSON` and `ToJSON`.
+* Add `To/FromJSONKey Void` instances
+
 ### 2.1.1.0
 
 - Add `Data.Aeson.KeyMap.!?` (flipped) alias to `Data.Aeson.KeyMap.lookup`.

src/Data/Aeson/TH.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
@@ -75,6 +76,9 @@ Please note that you can derive instances for tuples using the following syntax:
 $('deriveJSON' 'defaultOptions' ''(,,,))
 @
 
+If you derive `ToJSON` for a type that has no constructors, the splice will
+require enabling @EmptyCase@ to compile.
+
 -}
 module Data.Aeson.TH
     (
@@ -327,8 +331,8 @@ consToValue :: ToJSONFun
             -- ^ Constructors for which to generate JSON generating code.
             -> Q Exp
 
-consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "
-                             ++ "Not a single constructor given!"
+consToValue _ _ _ _ [] =
+    [| \x -> case x of {} |]
 
 consToValue target jc opts instTys cons = autoletE liftSBS $ \letInsert -> do
     value <- newName "value"
@@ -688,8 +692,8 @@ consFromJSON :: JSONClass
              -- ^ Constructors for which to generate JSON parsing code.
              -> Q Exp
 
-consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
-                                ++ "Not a single constructor given!"
+consFromJSON _ _ _ _ [] =
+    [| \_ -> fail "Attempted to parse empty type" |]
 
 consFromJSON jc tName opts instTys cons = do
   value <- newName "value"
@@ -1154,7 +1158,7 @@ instance {-# OVERLAPPABLE #-} LookupField a where
 
 instance {-# INCOHERENT #-} LookupField (Maybe a) where
     lookupField pj _ _ = parseOptionalFieldWith pj
- 
+
 #if !MIN_VERSION_base(4,16,0)
 instance {-# INCOHERENT #-} LookupField (Semigroup.Option a) where
     lookupField pj tName rec obj key =

src/Data/Aeson/Types/FromJSON.hs

@@ -978,6 +978,11 @@ class GFromJSON' arity f where
                 -> Value
                 -> Parser (f a)
 
+-- | No constructors.
+instance GFromJSON' arity V1 where
+    gParseJSON' _ _ = fail "Attempted to parse empty type"
+    {-# INLINE gParseJSON' #-}
+
 -- | Single constructor.
 instance ( ConsFromJSON arity a
          , AllNullary         (C1 c a) allNullary
@@ -1537,6 +1542,10 @@ instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
 instance FromJSON Void where
     parseJSON _ = fail "Cannot parse Void"
 
+-- | @since 2.1.2.0
+instance FromJSONKey Void where
+    fromJSONKey = FromJSONKeyTextParser $ \_ -> fail "Cannot parse Void"
+
 instance FromJSON Bool where
     parseJSON (Bool b) = pure b
     parseJSON v = typeMismatch "Bool" v

src/Data/Aeson/Types/ToJSON.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -829,6 +830,12 @@ instance ( ToJSON1 f
 --------------------------------------------------------------------------------
 -- Generic toEncoding
 
+instance GToJSON' Encoding arity V1 where
+    -- Empty values do not exist, which makes the job of formatting them
+    -- rather easy:
+    gToJSON _ _ x = case x of {}
+    {-# INLINE gToJSON #-}
+
 instance ToJSON a => GToJSON' Encoding arity (K1 i a) where
     -- Constant values are encoded using their ToJSON instance:
     gToJSON _opts _ = toEncoding . unK1
@@ -1306,6 +1313,10 @@ instance ToJSON Void where
     toJSON = absurd
     toEncoding = absurd
 
+-- | @since 2.1.2.0
+instance ToJSONKey Void where
+    toJSONKey = ToJSONKeyText absurd absurd
+
 instance ToJSON Bool where
     toJSON = Bool
     toEncoding = E.bool

tests/Encoders.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -408,6 +409,29 @@ thGADTToEncodingDefault = $(mkToEncoding defaultOptions ''GADT)
 thGADTParseJSONDefault :: Value -> Parser (GADT String)
 thGADTParseJSONDefault = $(mkParseJSON defaultOptions ''GADT)
 
+--------------------------------------------------------------------------------
+-- NoConstructors encoders/decoders
+--------------------------------------------------------------------------------
+
+thNoConstructorsToJSONDefault :: NoConstructors -> Value
+thNoConstructorsToJSONDefault = $(mkToJSON defaultOptions ''NoConstructors)
+
+thNoConstructorsToEncodingDefault :: NoConstructors -> Encoding
+thNoConstructorsToEncodingDefault = $(mkToEncoding defaultOptions ''NoConstructors)
+
+thNoConstructorsParseJSONDefault :: Value -> Parser NoConstructors
+thNoConstructorsParseJSONDefault = $(mkParseJSON defaultOptions ''NoConstructors)
+
+
+gNoConstructorsToJSONDefault :: NoConstructors -> Value
+gNoConstructorsToJSONDefault = genericToJSON defaultOptions
+
+gNoConstructorsToEncodingDefault :: NoConstructors -> Encoding
+gNoConstructorsToEncodingDefault = genericToEncoding defaultOptions
+
+gNoConstructorsParseJSONDefault :: Value -> Parser NoConstructors
+gNoConstructorsParseJSONDefault = genericParseJSON defaultOptions
+
 --------------------------------------------------------------------------------
 -- OneConstructor encoders/decoders
 --------------------------------------------------------------------------------

tests/Types.hs

@@ -47,6 +47,8 @@ data UFoo = UFoo {
     , uFooInt :: Int
     } deriving (Show, Eq, Data, Typeable)
 
+data NoConstructors
+
 data OneConstructor = OneConstructor
                       deriving (Show, Eq, Typeable, Data)
 
@@ -116,6 +118,7 @@ newtype OptionField = OptionField { optionField :: Option Int }
 
 deriving instance Generic Foo
 deriving instance Generic UFoo
+deriving instance Generic NoConstructors
 deriving instance Generic OneConstructor
 deriving instance Generic (Product2 a b)
 deriving instance Generic (Product6 a b c d e f)