Add Generically instances

This allows to "properly" derive ToJSON instances.

Author: phadej

aeson.cabal

@@ -107,6 +107,7 @@ library
   -- Compat
   build-depends:
       base-compat-batteries  >=0.10.0 && <0.13
+    , generically            >=0.1    && <0.2
     , time-compat            >=1.9.6  && <1.10
 
   if !impl(ghc >=8.6)
@@ -194,6 +195,7 @@ test-suite aeson-tests
     , dlist
     , filepath
     , generic-deriving      >=1.10     && <1.15
+    , generically
     , ghc-prim              >=0.2
     , hashable
     , indexed-traversable

benchmarks/aeson-benchmarks.cabal

@@ -31,6 +31,7 @@ library
     , data-fix
     , deepseq
     , dlist
+    , generically
     , ghc-prim
     , hashable
     , indexed-traversable

src/Data/Aeson/Types/FromJSON.hs

@@ -118,6 +118,9 @@ import Data.Word (Word16, Word32, Word64, Word8)
 import Foreign.Storable (Storable)
 import Foreign.C.Types (CTime (..))
 import GHC.Generics
+#if !MIN_VERSION_base(4,17,0)
+import GHC.Generics.Generically (Generically (..), Generically1 (..))
+#endif
 import Numeric.Natural (Natural)
 import Text.ParserCombinators.ReadP (readP_to_S)
 import Unsafe.Coerce (unsafeCoerce)
@@ -362,6 +365,12 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
 -- instance 'FromJSON' Coord
 -- @
 --
+-- or using the [DerivingVia extension](https://downloads.haskell.org/ghc/9.2.3/docs/html/users_guide/exts/deriving_via.html)
+--
+-- @
+-- deriving via 'Generically' Coord instance 'FromJSON' Coord
+-- @
+--
 -- The default implementation will be equivalent to
 -- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different
 -- options, you can customize the generic decoding by defining:
@@ -386,6 +395,10 @@ class FromJSON a where
         . V.toList
         $ a
 
+-- | @since 2.1.0.0
+instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (Generically a) where
+    parseJSON = coerce (genericParseJSON defaultOptions :: Value -> Parser a)
+
 -------------------------------------------------------------------------------
 --  Classes and types for map keys
 -------------------------------------------------------------------------------
@@ -575,6 +588,12 @@ typeOf v = case v of
 -- instance 'FromJSON' a => 'FromJSON1' (Pair a)
 -- @
 --
+-- or
+--
+-- @
+-- deriving via 'Generically1' (Pair a) instance 'FromJSON1' (Pair a)
+-- @
+--
 -- If the default implementation doesn't give exactly the results you want,
 -- you can customize the generic decoding with only a tiny amount of
 -- effort, using 'genericLiftParseJSON' with your preferred 'Options':
@@ -597,6 +616,11 @@ class FromJSON1 f where
     liftParseJSONList :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser [f a]
     liftParseJSONList f g v = listParser (liftParseJSON f g) v
 
+-- | @since 2.1.0.0
+instance (Generic1 f, GFromJSON One (Rep1 f)) => FromJSON1 (Generically1 f) where
+    liftParseJSON :: forall a. (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (Generically1 f a)
+    liftParseJSON = coerce (genericLiftParseJSON defaultOptions :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a))
+
 -- | Lift the standard 'parseJSON' function through the type constructor.
 parseJSON1 :: (FromJSON1 f, FromJSON a) => Value -> Parser (f a)
 parseJSON1 = liftParseJSON parseJSON parseJSONList

src/Data/Aeson/Types/ToJSON.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -68,6 +69,7 @@ import qualified Data.Aeson.Key as Key
 import qualified Data.Aeson.KeyMap as KM
 import Data.Attoparsec.Number (Number(..))
 import Data.Bits (unsafeShiftR)
+import Data.Coerce (coerce)
 import Data.DList (DList)
 import Data.Fixed (Fixed, HasResolution, Nano)
 import Data.Foldable (toList)
@@ -101,6 +103,9 @@ import Data.Word (Word16, Word32, Word64, Word8)
 import Foreign.Storable (Storable)
 import Foreign.C.Types (CTime (..))
 import GHC.Generics
+#if !MIN_VERSION_base(4,17,0)
+import GHC.Generics.Generically (Generically (..), Generically1 (..))
+#endif
 import Numeric.Natural (Natural)
 import qualified Data.Aeson.Encoding as E
 import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding, key)
@@ -256,6 +261,12 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1
 --     'toEncoding' = 'genericToEncoding' 'defaultOptions'
 -- @
 --
+-- or more conveniently using the [DerivingVia extension](https://downloads.haskell.org/ghc/9.2.3/docs/html/users_guide/exts/deriving_via.html)
+--
+-- @
+-- deriving via 'Generically' Coord instance 'ToJSON' Coord
+-- @
+--
 -- If on the other hand you wish to customize the generic decoding, you have
 -- to implement both methods:
 --
@@ -272,7 +283,7 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1
 -- Previous versions of this library only had the 'toJSON' method. Adding
 -- 'toEncoding' had two reasons:
 --
--- 1. toEncoding is more efficient for the common case that the output of
+-- 1. 'toEncoding' is more efficient for the common case that the output of
 -- 'toJSON' is directly serialized to a @ByteString@.
 -- Further, expressing either method in terms of the other would be
 -- non-optimal.
@@ -321,6 +332,11 @@ class ToJSON a where
     toEncodingList :: [a] -> Encoding
     toEncodingList = listEncoding toEncoding
 
+-- | @since 2.1.0.0
+instance (Generic a, GToJSON' Value Zero (Rep a), GToJSON' Encoding Zero (Rep a)) => ToJSON (Generically a) where
+    toJSON     = coerce (genericToJSON     defaultOptions :: a -> Value)
+    toEncoding = coerce (genericToEncoding defaultOptions :: a -> Encoding)
+
 -------------------------------------------------------------------------------
 -- Object key-value pairs
 -------------------------------------------------------------------------------
@@ -615,6 +631,14 @@ class ToJSON1 f where
     liftToEncodingList :: (a -> Encoding) -> ([a] -> Encoding) -> [f a] -> Encoding
     liftToEncodingList f g = listEncoding (liftToEncoding f g)
 
+-- | @since 2.1.0.0
+instance (Generic1 f, GToJSON' Value One (Rep1 f), GToJSON' Encoding One (Rep1 f)) => ToJSON1 (Generically1 f) where
+    liftToJSON :: forall a. (a -> Value) -> ([a] -> Value) -> Generically1 f a -> Value
+    liftToJSON = coerce (genericLiftToJSON defaultOptions :: (a -> Value) -> ([a] -> Value) -> f a -> Value)
+
+    liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> Generically1 f a -> Encoding
+    liftToEncoding = coerce (genericLiftToEncoding defaultOptions :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding)
+
 -- | Lift the standard 'toJSON' function through the type constructor.
 toJSON1 :: (ToJSON1 f, ToJSON a) => f a -> Value
 toJSON1 = liftToJSON toJSON toJSONList

tests/UnitTests.hs

@@ -9,6 +9,11 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecursiveDo #-}
 
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE StandaloneDeriving #-}
+#endif
+
 -- For Data.Aeson.Types.camelTo
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
@@ -55,6 +60,7 @@ import Data.Text (Text)
 import Data.Time (UTCTime)
 import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
 import GHC.Generics (Generic)
+import GHC.Generics.Generically (Generically (..))
 import Instances ()
 import Numeric.Natural (Natural)
 import System.Directory (getDirectoryContents)
@@ -97,9 +103,13 @@ data Wibble = Wibble {
 
 instance FromJSON Wibble
 
+#if __GLASGOW_HASKELL__ >= 806
+deriving via Generically Wibble instance ToJSON Wibble
+#else
 instance ToJSON Wibble where
     toJSON     = genericToJSON defaultOptions
     toEncoding = genericToEncoding defaultOptions
+#endif
 
 -- Test that if we put a bomb in a data structure, but only demand
 -- part of it via lazy encoding, we do not unexpectedly fail.