Commits

Bryan O'Sullivan  committed 9ede02d Merge

Merge with Bas

  • Participants
  • Parent commits 5a8f56a, e9ff414

Comments (0)

Files changed (5)

File Data/Aeson/Generic.hs

     , toJSON
     ) where
 
-import Data.Aeson.Types.Internal (Value, Result, genericFromJSON, genericToJSON)
-import Data.Data (Data)
+import Control.Applicative ((<$>))
+import Control.Arrow (first)
+import Control.Monad.State.Strict
+import Data.Aeson.Functions
+import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON)
+import Data.Attoparsec.Number (Number)
+import Data.Generics
+import Data.Hashable (Hashable)
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.IntSet (IntSet)
+import Data.Maybe (fromJust)
+import Data.Text (Text, pack, unpack)
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time.Clock (UTCTime)
+import Data.Word (Word, Word8, Word16, Word32, Word64)
+import qualified Data.Aeson.Types as T
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import qualified Data.HashMap.Strict as H
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as DT
+import qualified Data.Text.Lazy as LT
+import qualified Data.Traversable as T
+import qualified Data.Vector as V
+
+type T a = a -> Value
+
+toJSON :: (Data a) => a -> Value
+toJSON = toJSON_generic
+         `ext1Q` list
+         `ext1Q` vector
+         `ext1Q` set
+         `ext2Q'` mapAny
+         `ext2Q'` hashMapAny
+         -- Use the standard encoding for all base types.
+         `extQ` (T.toJSON :: T Integer)
+         `extQ` (T.toJSON :: T Int)
+         `extQ` (T.toJSON :: T Int8)
+         `extQ` (T.toJSON :: T Int16)
+         `extQ` (T.toJSON :: T Int32)
+         `extQ` (T.toJSON :: T Int64)
+         `extQ` (T.toJSON :: T Word)
+         `extQ` (T.toJSON :: T Word8)
+         `extQ` (T.toJSON :: T Word16)
+         `extQ` (T.toJSON :: T Word32)
+         `extQ` (T.toJSON :: T Word64)
+         `extQ` (T.toJSON :: T Double)
+         `extQ` (T.toJSON :: T Number)
+         `extQ` (T.toJSON :: T Float)
+         `extQ` (T.toJSON :: T Rational)
+         `extQ` (T.toJSON :: T Char)
+         `extQ` (T.toJSON :: T Text)
+         `extQ` (T.toJSON :: T LT.Text)
+         `extQ` (T.toJSON :: T String)
+         `extQ` (T.toJSON :: T B.ByteString)
+         `extQ` (T.toJSON :: T L.ByteString)
+         `extQ` (T.toJSON :: T T.Value)
+         `extQ` (T.toJSON :: T DotNetTime)
+         `extQ` (T.toJSON :: T UTCTime)
+         `extQ` (T.toJSON :: T IntSet)
+         `extQ` (T.toJSON :: T Bool)
+         `extQ` (T.toJSON :: T ())
+         --`extQ` (T.toJSON :: T Ordering)
+  where
+    list xs = Array . V.fromList . map toJSON $ xs
+    vector v = Array . V.map toJSON $ v
+    set s = Array . V.fromList . map toJSON . Set.toList $ s
+
+    mapAny m
+      | tyrep == typeOf DT.empty = remap id
+      | tyrep == typeOf LT.empty = remap LT.toStrict
+      | tyrep == typeOf ""       = remap pack
+      | tyrep == typeOf B.empty  = remap decode
+      | tyrep == typeOf L.empty  = remap strict
+      | otherwise = modError "toJSON" $
+                             "cannot convert map keyed by type " ++ show tyrep
+      where tyrep = typeOf . head . Map.keys $ m
+            remap f = Object . transformMap (f . fromJust . cast) toJSON $ m
+
+    hashMapAny m
+      | tyrep == typeOf DT.empty = remap id
+      | tyrep == typeOf LT.empty = remap LT.toStrict
+      | tyrep == typeOf ""       = remap pack
+      | tyrep == typeOf B.empty  = remap decode
+      | tyrep == typeOf L.empty  = remap strict
+      | otherwise = modError "toJSON" $
+                             "cannot convert map keyed by type " ++ show tyrep
+      where tyrep = typeOf . head . H.keys $ m
+            remap f = Object . hashMap (f . fromJust . cast) toJSON $ m
+
+
+toJSON_generic :: (Data a) => a -> Value
+toJSON_generic = generic
+  where
+        -- Generic encoding of an algebraic data type.
+        generic a =
+            case dataTypeRep (dataTypeOf a) of
+                -- No constructor, so it must be an error value.  Code
+                -- it anyway as Null.
+                AlgRep []  -> Null
+                -- Elide a single constructor and just code the arguments.
+                AlgRep [c] -> encodeArgs c (gmapQ toJSON a)
+                -- For multiple constructors, make an object with a
+                -- field name that is the constructor (except lower
+                -- case) and the data is the arguments encoded.
+                AlgRep _   -> encodeConstr (toConstr a) (gmapQ toJSON a)
+                rep        -> err (dataTypeOf a) rep
+           where
+              err dt r = modError "toJSON" $ "not AlgRep " ++
+                                  show r ++ "(" ++ show dt ++ ")"
+        -- Encode nullary constructor as a string.
+        -- Encode non-nullary constructors as an object with the constructor
+        -- name as the single field and the arguments as the value.
+        -- Use an array if the are no field names, but elide singleton arrays,
+        -- and use an object if there are field names.
+        encodeConstr c [] = String . constrString $ c
+        encodeConstr c as = object [(constrString c, encodeArgs c as)]
+
+        constrString = pack . showConstr
+
+        encodeArgs c = encodeArgs' (constrFields c)
+        encodeArgs' [] [j] = j
+        encodeArgs' [] js  = Array . V.fromList $ js
+        encodeArgs' ns js  = object $ zip (map mungeField ns) js
+
+        -- Skip leading '_' in field name so we can use keywords
+        -- etc. as field names.
+        mungeField ('_':cs) = pack cs
+        mungeField cs       = pack cs
 
 fromJSON :: (Data a) => Value -> Result a
-fromJSON = genericFromJSON
+fromJSON = parse parseJSON
 
-toJSON :: (Data a) => a -> Value
-toJSON = genericToJSON
+type F a = Parser a
+
+parseJSON :: (Data a) => Value -> Parser a
+parseJSON j = parseJSON_generic j
+             `ext1R` list
+             `ext1R` vector
+             `ext2R'` mapAny
+             `ext2R'` hashMapAny
+             -- Use the standard encoding for all base types.
+             `extR` (value :: F Integer)
+             `extR` (value :: F Int)
+             `extR` (value :: F Int8)
+             `extR` (value :: F Int16)
+             `extR` (value :: F Int32)
+             `extR` (value :: F Int64)
+             `extR` (value :: F Word)
+             `extR` (value :: F Word8)
+             `extR` (value :: F Word16)
+             `extR` (value :: F Word32)
+             `extR` (value :: F Word64)
+             `extR` (value :: F Double)
+             `extR` (value :: F Number)
+             `extR` (value :: F Float)
+             `extR` (value :: F Rational)
+             `extR` (value :: F Char)
+             `extR` (value :: F Text)
+             `extR` (value :: F LT.Text)
+             `extR` (value :: F String)
+             `extR` (value :: F B.ByteString)
+             `extR` (value :: F L.ByteString)
+             `extR` (value :: F T.Value)
+             `extR` (value :: F DotNetTime)
+             `extR` (value :: F UTCTime)
+             `extR` (value :: F IntSet)
+             `extR` (value :: F Bool)
+             `extR` (value :: F ())
+  where
+    value :: (T.FromJSON a) => Parser a
+    value = T.parseJSON j
+    list :: (Data a) => Parser [a]
+    list = V.toList <$> parseJSON j
+    vector :: (Data a) => Parser (V.Vector a)
+    vector = case j of
+               Array js -> V.mapM parseJSON js
+               _        -> myFail
+    mapAny :: forall e f. (Data e, Data f) => Parser (Map.Map f e)
+    mapAny
+        | tyrep `elem` stringyTypes = res
+        | otherwise = myFail
+      where res = case j of
+                Object js -> Map.mapKeysMonotonic trans <$> T.mapM parseJSON js
+                _         -> myFail
+            trans
+               | tyrep == typeOf DT.empty = remap id
+               | tyrep == typeOf LT.empty = remap LT.fromStrict
+               | tyrep == typeOf ""       = remap DT.unpack
+               | tyrep == typeOf B.empty  = remap encodeUtf8
+               | tyrep == typeOf L.empty  = remap lazy
+               | otherwise = modError "parseJSON"
+                                      "mapAny -- should never happen"
+            tyrep = typeOf (undefined :: f)
+            remap f = fromJust . cast . f
+    hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)
+    hashMapAny
+        | tyrep == typeOf ""       = process DT.unpack
+        | tyrep == typeOf LT.empty = process LT.fromStrict
+        | tyrep == typeOf DT.empty = process id
+        | otherwise = myFail
+      where
+        process f = maybe myFail return . cast =<< parseWith f
+        parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)
+        parseWith f = case j of
+                        Object js -> H.fromList . map (first f) . Map.toList <$>
+                                     T.mapM parseJSON js
+                        _          -> myFail
+        tyrep = typeOf (undefined :: f)
+    myFail = modFail "parseJSON" $ "bad data: " ++ show j
+    stringyTypes = [typeOf LT.empty, typeOf DT.empty, typeOf B.empty,
+                    typeOf L.empty, typeOf ""]
+
+parseJSON_generic :: (Data a) => Value -> Parser a
+parseJSON_generic j = generic
+  where
+        typ = dataTypeOf $ resType generic
+        generic = case dataTypeRep typ of
+                    AlgRep []  -> case j of
+                                    Null -> return (modError "parseJSON" "empty type")
+                                    _ -> modFail "parseJSON" "no-constr bad data"
+                    AlgRep [_] -> decodeArgs (indexConstr typ 1) j
+                    AlgRep _   -> do (c, j') <- getConstr typ j; decodeArgs c j'
+                    rep        -> modFail "parseJSON" $
+                                  show rep ++ "(" ++ show typ ++ ")"
+        getConstr t (Object o) | [(s, j')] <- fromJSObject o = do
+                                                c <- readConstr' t s
+                                                return (c, j')
+        getConstr t (String js) = do c <- readConstr' t (unpack js)
+                                     return (c, Null) -- handle nullary ctor
+        getConstr _ _ = modFail "parseJSON" "bad constructor encoding"
+        readConstr' t s =
+          maybe (modFail "parseJSON" $ "unknown constructor: " ++ s ++ " " ++
+                         show t)
+                return $ readConstr t s
+
+        decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
+                           (constrFields c0)
+         where
+          go 0 c  _       Null       = construct c []   -- nullary constructor
+          go 1 c []       jd         = construct c [jd] -- unary constructor
+          go n c []       (Array js)
+              | n > 1 = construct c (V.toList js)   -- no field names
+          -- FIXME? We could allow reading an array into a constructor
+          -- with field names.
+          go _ c fs@(_:_) (Object o) = selectFields o fs >>=
+                                       construct c -- field names
+          go _ c _        jd         = modFail "parseJSON" $
+                                       "bad decodeArgs data " ++ show (c, jd)
+
+        fromJSObject = map (first unpack) . Map.toList
+
+        -- Build the value by stepping through the list of subparts.
+        construct c = evalStateT $ fromConstrM f c
+          where f :: (Data a) => StateT [Value] Parser a
+                f = do js <- get
+                       case js of
+                         [] -> lift $ modFail "construct" "empty list"
+                         (j':js') -> do put js'; lift $ parseJSON j'
+
+        -- Select the named fields from a JSON object.
+        selectFields fjs = mapM sel
+          where sel f = maybe (modFail "parseJSON" $ "field does not exist " ++
+                               f) return $ Map.lookup (pack f) fjs
+
+        -- Count how many arguments a constructor has.  The value x is
+        -- used to determine what type the constructor returns.
+        numConstrArgs :: (Data a) => a -> Constr -> Int
+        numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0
+          where f = do modify (+1); return undefined
+
+        resType :: MonadPlus m => m a -> a
+        resType _ = modError "parseJSON" "resType"
+
+modFail :: (Monad m) => String -> String -> m a
+modFail func err = fail $ "Data.Aeson.Generic." ++ func ++ ": " ++ err
+
+modError :: String -> String -> a
+modError func err = error $ "Data.Aeson.Generic." ++ func ++ ": " ++ err
+
+
+-- Type extension for binary type constructors.
+
+-- | Flexible type extension
+ext2' :: (Data a, Typeable2 t)
+     => c a
+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
+     -> c a
+ext2' def ext = maybe def id (dataCast2 ext)
+
+-- | Type extension of queries for type constructors
+ext2Q' :: (Data d, Typeable2 t)
+      => (d -> q)
+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
+      -> d -> q
+ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
+
+-- | Type extension of readers for type constructors
+ext2R' :: (Monad m, Data d, Typeable2 t)
+      => m d
+      -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
+      -> m d
+ext2R' def ext = unR ((R def) `ext2'` (R ext))
+
+-- | The type constructor for queries
+newtype Q q x = Q { unQ :: x -> q }
+
+-- | The type constructor for readers
+newtype R m x = R { unR :: m x }

File Data/Aeson/Types/Internal.hs

     ScopedTypeVariables, PatternGuards #-}
 
 {-# LANGUAGE CPP #-}
-#ifdef DEFAULT_SIGNATURES
-{-# LANGUAGE DefaultSignatures #-}
+#ifdef GENERICS
+{-# LANGUAGE DefaultSignatures
+           , TypeOperators
+           , EmptyDataDecls
+           , KindSignatures
+           , MultiParamTypeClasses
+           , FunctionalDependencies
+  #-}
 #endif
 
 -- |
     -- * Core JSON types
       Value(..)
     , Array
-    , emptyArray
+    , emptyArray, isEmptyArray
     , Pair
     , Object
     , emptyObject
     , (.:)
     , (.:?)
     , object
-    -- * Generic toJSON and fromJSON
-    , genericToJSON
-    , genericFromJSON
     ) where
 
 import Control.Applicative
-import Control.Arrow (first)
+import Control.DeepSeq (NFData(..))
 import Control.Monad.State.Strict
-import Control.DeepSeq (NFData(..))
 import Data.Aeson.Functions
 import Data.Attoparsec.Char8 (Number(..))
-import Data.Generics
+import Data.Data (Data)
 import Data.Hashable (Hashable(..))
 import Data.Int (Int8, Int16, Int32, Int64)
-import Data.IntSet (IntSet)
 import Data.List (foldl')
 import Data.Map (Map)
-import Data.Maybe (fromJust)
 import Data.Monoid (Dual(..), First(..), Last(..))
 import Data.Monoid (Monoid(..))
 import Data.Ratio (Ratio)
 import Data.String (IsString(..))
+import Data.Text.Encoding (encodeUtf8)
 import Data.Text (Text, pack, unpack)
-import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Format (FormatTime, formatTime, parseTime)
-import Data.Vector (Vector)
+import Data.Typeable (Typeable)
+import Data.Vector (Vector, (!?))
 import Data.Word (Word, Word8, Word16, Word32, Word64)
 import Foreign.Storable (Storable)
 import System.Locale (defaultTimeLocale)
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as LT
-import qualified Data.Traversable as T
 import qualified Data.Vector as V
 import qualified Data.Vector.Storable as VS
 import qualified Data.Vector.Primitive as VP
 import qualified Data.Vector.Unboxed as VU
 import qualified Data.Vector.Generic as VG
 
+#ifdef GENERICS
+import GHC.Generics
+#endif
 
 -- | The result of running a 'Parser'.
 data Result a = Error String
     {-# INLINE pure #-}
     (<*>) = apP
     {-# INLINE (<*>) #-}
-    
+
 instance Alternative Parser where
     empty = fail "empty"
     {-# INLINE empty #-}
 emptyArray :: Value
 emptyArray = Array V.empty
 
+-- | Determines if the 'Value' is an empty 'Array'.
+-- Note that: @isEmptyArray 'emptyArray'@.
+isEmptyArray :: Value -> Bool
+isEmptyArray (Array arr) = V.null arr
+isEmptyArray _ = False
+
 -- | The empty object.
 emptyObject :: Value
 emptyObject = Object M.empty
 --   toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]
 -- @
 --
--- We use the @OverloadedStrings@ language extension so that we can
--- write 'Text' values as normal double-quoted strings.
+-- Note the use of the @OverloadedStrings@ language extension which enables
+-- 'Text' values to be written as string literals.
 --
--- If you do not want to write your own 'ToJSON' instances, you have
--- two options:
+-- Instead of manually writing your 'ToJSON' instance, there are three options
+-- to do it automatically:
 --
--- * The 'Data.Aeson.TH' module will automatically derive an instance
---   for you with a single line of code.
+-- * 'Data.Aeson.TH' provides template-haskell functions which will derive an
+-- instance at compile-time. The generated instance is optimized for your type
+-- so will probably be more efficient than the following two options:
 --
--- * The 'Data.Aeson.Generic' module will work with most data types
---   that are instances of 'Data' (but note, this can be slow).
+-- * 'Data.Aeson.Generic' provides a generic @toJSON@ function that accepts any
+-- type which is an instance of 'Data'.
+-- 
+-- * If your compiler has support for the @DeriveGeneric@ and
+-- @DefaultSignatures@ language extensions, @toJSON@ will have a default generic
+-- implementation.
+--
+-- To use the latter option, simply add a @deriving 'Generic'@ clause to your
+-- datatype and declare a @ToJSON@ instance for your datatype without giving a
+-- definition for @toJSON@.
+--
+-- For example the previous example can be simplified to just:
+--
+-- @{-\# LANGUAGE DeriveGeneric \#-}
+--
+-- import GHC.Generics
+--
+-- data Coord { x :: Double, y :: Double } deriving Generic
+--
+-- instance ToJSON Coord
+-- @
 class ToJSON a where
     toJSON   :: a -> Value
 
-#ifdef DEFAULT_SIGNATURES
-    default toJSON :: Data a => a -> Value
-    toJSON = genericToJSON
+#ifdef GENERICS
+    default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
+    toJSON = gToJSON . from
 #endif
 
 -- | A type that can be converted from JSON, with the possibility of
 -- data Coord { x :: Double, y :: Double }
 -- 
 -- instance FromJSON Coord where
---   parseJSON ('Object' v) = Coord '<$>'
---                         v '.:' \"x\" '<*>'
---                         v '.:' \"y\"
+--   parseJSON ('Object' v) = Coord    '<$>'
+--                          v '.:' \"x\" '<*>'
+--                          v '.:' \"y\"
 --
 --   \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail.
 --   parseJSON _          = 'mzero'
 -- @
 --
--- We use the @OverloadedStrings@ language extension so that we can
--- write 'Text' values as normal double-quoted strings.
+-- Note the use of the @OverloadedStrings@ language extension which enables
+-- 'Text' values to be written as string literals.
 --
--- If you do not want to write your own 'FromJSON' instances, you have
--- two options:
+-- Instead of manually writing your 'FromJSON' instance, there are three options
+-- to do it automatically:
 --
--- * The 'Data.Aeson.TH' module will automatically derive an instance
---   for you with a single line of code.
+-- * 'Data.Aeson.TH' provides template-haskell functions which will derive an
+-- instance at compile-time. The generated instance is optimized for your type
+-- so will probably be more efficient than the following two options:
 --
--- * The 'Data.Aeson.Generic' module will work with most data types
---   that are instances of 'Data' (but note, this can be slow).
+-- * 'Data.Aeson.Generic' provides a generic @fromJSON@ function that parses to
+-- any type which is an instance of 'Data'.
+--
+-- * If your compiler has support for the @DeriveGeneric@ and
+-- @DefaultSignatures@ language extensions, @parseJSON@ will have a default
+-- generic implementation.
+--
+-- To use this, simply add a @deriving 'Generic'@ clause to your datatype and
+-- declare a @FromJSON@ instance for your datatype without giving a definition
+-- for @parseJSON@.
+--
+-- For example the previous example can be simplified to just:
+--
+-- @{-\# LANGUAGE DeriveGeneric \#-}
+--
+-- import GHC.Generics
+--
+-- data Coord { x :: Double, y :: Double } deriving Generic
+--
+-- instance FromJSON Coord
+-- @
 class FromJSON a where
     parseJSON :: Value -> Parser a
 
-#ifdef DEFAULT_SIGNATURES
-    default parseJSON :: Data a => Value -> Parser a
-    parseJSON = genericParseJSON
+#ifdef GENERICS
+    default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
+    parseJSON = fmap to . gParseJSON
 #endif
 
 instance (ToJSON a) => ToJSON (Maybe a) where
     toJSON (Just a) = toJSON a
     toJSON Nothing  = Null
     {-# INLINE toJSON #-}
-    
+
 instance (FromJSON a) => FromJSON (Maybe a) where
     parseJSON Null   = pure Nothing
     parseJSON a      = Just <$> parseJSON a
     toJSON (Left a)  = object [left  .= a]
     toJSON (Right b) = object [right .= b]
     {-# INLINE toJSON #-}
-    
+
 instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
     parseJSON (Object (M.toList -> [(key, value)]))
         | key == left  = Left  <$> parseJSON value
 instance (ToJSON a) => ToJSON [a] where
     toJSON = Array . V.fromList . map toJSON
     {-# INLINE toJSON #-}
-    
+
 instance (FromJSON a) => FromJSON [a] where
     parseJSON (Array a) = mapM parseJSON (V.toList a)
     parseJSON v         = typeMismatch "[a]" v
 instance (ToJSON a) => ToJSON (Vector a) where
     toJSON = Array . V.map toJSON
     {-# INLINE toJSON #-}
-    
+
 instance (FromJSON a) => FromJSON (Vector a) where
     parseJSON (Array a) = V.mapM parseJSON a
     parseJSON v         = typeMismatch "Vector a" v
 instance (ToJSON a) => ToJSON (Set.Set a) where
     toJSON = toJSON . Set.toList
     {-# INLINE toJSON #-}
-    
+
 instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
     parseJSON = fmap Set.fromList . parseJSON
     {-# INLINE parseJSON #-}
 instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
     toJSON = toJSON . HashSet.toList
     {-# INLINE toJSON #-}
-    
+
 instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
     parseJSON = fmap HashSet.fromList . parseJSON
     {-# INLINE parseJSON #-}
 instance ToJSON IntSet.IntSet where
     toJSON = toJSON . IntSet.toList
     {-# INLINE toJSON #-}
-    
+
 instance FromJSON IntSet.IntSet where
     parseJSON = fmap IntSet.fromList . parseJSON
     {-# INLINE parseJSON #-}
 instance ToJSON a => ToJSON (IntMap.IntMap a) where
     toJSON = toJSON . IntMap.toList
     {-# INLINE toJSON #-}
-  
+
 instance FromJSON a => FromJSON (IntMap.IntMap a) where
     parseJSON = fmap IntMap.fromList . parseJSON
     {-# INLINE parseJSON #-}
              Bool _   -> "Boolean"
              Null     -> "Null"
 
+#ifdef GENERICS
+--------------------------------------------------------------------------------
+-- Generic toJSON
+
+class GToJSON f where
+    gToJSON :: f a -> Value
+
+instance (GToJSON a) => GToJSON (M1 i c a) where
+    gToJSON = gToJSON . unM1
+    {-# INLINE gToJSON #-}
+
+instance (ToJSON a) => GToJSON (K1 i a) where
+    gToJSON = toJSON . unK1
+    {-# INLINE gToJSON #-}
+
+instance GToJSON U1 where
+    gToJSON _ = emptyArray
+    {-# INLINE gToJSON #-}
+
+instance (ConsToJSON a) => GToJSON (C1 c a) where
+    gToJSON = consToJSON . unM1
+    {-# INLINE gToJSON #-}
+
+instance (GProductToValues a, GProductToValues b) => GToJSON (a :*: b) where
+    gToJSON = toJSON . toList . gProductToValues
+    {-# INLINE gToJSON #-}
+
+instance (GObject a, GObject b) => GToJSON (a :+: b) where
+    gToJSON (L1 x) = Object $ gObject x
+    gToJSON (R1 x) = Object $ gObject x
+    {-# INLINE gToJSON #-}
 
 --------------------------------------------------------------------------------
--- Generic toJSON and fromJSON
 
-type T a = a -> Value
+class ConsToJSON    f where consToJSON  ::           f a -> Value
+class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
 
-genericToJSON :: (Data a) => a -> Value
-genericToJSON = toJSON_generic
-         `ext1Q` list
-         `ext1Q` vector
-         `ext1Q` set
-         `ext2Q'` mapAny
-         `ext2Q'` hashMapAny
-         -- Use the standard encoding for all base types.
-         `extQ` (toJSON :: T Integer)
-         `extQ` (toJSON :: T Int)
-         `extQ` (toJSON :: T Int8)
-         `extQ` (toJSON :: T Int16)
-         `extQ` (toJSON :: T Int32)
-         `extQ` (toJSON :: T Int64)
-         `extQ` (toJSON :: T Word)
-         `extQ` (toJSON :: T Word8)
-         `extQ` (toJSON :: T Word16)
-         `extQ` (toJSON :: T Word32)
-         `extQ` (toJSON :: T Word64)
-         `extQ` (toJSON :: T Double)
-         `extQ` (toJSON :: T Number)
-         `extQ` (toJSON :: T Float)
-         `extQ` (toJSON :: T Rational)
-         `extQ` (toJSON :: T Char)
-         `extQ` (toJSON :: T Text)
-         `extQ` (toJSON :: T LT.Text)
-         `extQ` (toJSON :: T String)
-         `extQ` (toJSON :: T B.ByteString)
-         `extQ` (toJSON :: T LB.ByteString)
-         `extQ` (toJSON :: T Value)
-         `extQ` (toJSON :: T DotNetTime)
-         `extQ` (toJSON :: T UTCTime)
-         `extQ` (toJSON :: T IntSet)
-         `extQ` (toJSON :: T Bool)
-         `extQ` (toJSON :: T ())
-         --`extQ` (T.toJSON :: T Ordering)
-  where
-    list xs = Array . V.fromList . map genericToJSON $ xs
-    vector v = Array . V.map genericToJSON $ v
-    set s = Array . V.fromList . map genericToJSON . Set.toList $ s
+instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
+    consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
+    {-# INLINE consToJSON #-}
 
-    mapAny m
-      | tyrep == typeOf T.empty  = remap id
-      | tyrep == typeOf LT.empty = remap LT.toStrict
-      | tyrep == typeOf string   = remap pack
-      | tyrep == typeOf B.empty  = remap decode
-      | tyrep == typeOf LB.empty = remap strict
-      | otherwise = modError "genericToJSON" $
-                             "cannot convert map keyed by type " ++ show tyrep
-      where tyrep = typeOf . head . M.keys $ m
-            remap f = Object . transformMap (f . fromJust . cast) genericToJSON $ m
+instance (GRecordToPairs f) => ConsToJSON' True f where
+    consToJSON' = Tagged (object . toList . gRecordToPairs)
+    {-# INLINE consToJSON' #-}
 
-    hashMapAny m
-      | tyrep == typeOf T.empty  = remap id
-      | tyrep == typeOf LT.empty = remap LT.toStrict
-      | tyrep == typeOf string   = remap pack
-      | tyrep == typeOf B.empty  = remap decode
-      | tyrep == typeOf LB.empty = remap strict
-      | otherwise = modError "genericToJSON" $
-                             "cannot convert map keyed by type " ++ show tyrep
-      where tyrep = typeOf . head . H.keys $ m
-            remap f = Object . hashMap (f . fromJust . cast) genericToJSON $ m
+instance GToJSON f => ConsToJSON' False f where
+    consToJSON' = Tagged gToJSON
+    {-# INLINE consToJSON' #-}
 
+--------------------------------------------------------------------------------
 
-toJSON_generic :: (Data a) => a -> Value
-toJSON_generic = generic
-  where
-        -- Generic encoding of an algebraic data type.
-        generic a =
-            case dataTypeRep (dataTypeOf a) of
-                -- No constructor, so it must be an error value.  Code
-                -- it anyway as Null.
-                AlgRep []  -> Null
-                -- Elide a single constructor and just code the arguments.
-                AlgRep [c] -> encodeArgs c (gmapQ genericToJSON a)
-                -- For multiple constructors, make an object with a
-                -- field name that is the constructor (except lower
-                -- case) and the data is the arguments encoded.
-                AlgRep _   -> encodeConstr (toConstr a) (gmapQ genericToJSON a)
-                rep        -> err (dataTypeOf a) rep
-           where
-              err dt r = modError "genericToJSON" $ "not AlgRep " ++
-                                  show r ++ "(" ++ show dt ++ ")"
-        -- Encode nullary constructor as a string.
-        -- Encode non-nullary constructors as an object with the constructor
-        -- name as the single field and the arguments as the value.
-        -- Use an array if the are no field names, but elide singleton arrays,
-        -- and use an object if there are field names.
-        encodeConstr c [] = String . constrString $ c
-        encodeConstr c as = object [(constrString c, encodeArgs c as)]
+class GRecordToPairs f where
+    gRecordToPairs :: f a -> DList Pair
 
-        constrString = pack . showConstr
+instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where
+    gRecordToPairs (a :*: b) = gRecordToPairs a `append` gRecordToPairs b
+    {-# INLINE gRecordToPairs #-}
 
-        encodeArgs c = encodeArgs' (constrFields c)
-        encodeArgs' [] [j] = j
-        encodeArgs' [] js  = Array . V.fromList $ js
-        encodeArgs' ns js  = object $ zip (map mungeField ns) js
+instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
+    gRecordToPairs m1 = singleton (pack (selName m1), gToJSON (unM1 m1))
+    {-# INLINE gRecordToPairs #-}
 
-        -- Skip leading '_' in field name so we can use keywords
-        -- etc. as field names.
-        mungeField ('_':cs) = pack cs
-        mungeField cs       = pack cs
+--------------------------------------------------------------------------------
 
-genericFromJSON :: (Data a) => Value -> Result a
-genericFromJSON = parse genericParseJSON
+class GProductToValues f where
+    gProductToValues :: f a -> DList Value
 
-type F a = Parser a
+instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
+    gProductToValues (a :*: b) = gProductToValues a `append` gProductToValues b
+    {-# INLINE gProductToValues #-}
 
-genericParseJSON :: (Data a) => Value -> Parser a
-genericParseJSON j = parseJSON_generic j
-             `ext1R` list
-             `ext1R` vector
-             `ext2R'` mapAny
-             `ext2R'` hashMapAny
-             -- Use the standard encoding for all base types.
-             `extR` (value :: F Integer)
-             `extR` (value :: F Int)
-             `extR` (value :: F Int8)
-             `extR` (value :: F Int16)
-             `extR` (value :: F Int32)
-             `extR` (value :: F Int64)
-             `extR` (value :: F Word)
-             `extR` (value :: F Word8)
-             `extR` (value :: F Word16)
-             `extR` (value :: F Word32)
-             `extR` (value :: F Word64)
-             `extR` (value :: F Double)
-             `extR` (value :: F Number)
-             `extR` (value :: F Float)
-             `extR` (value :: F Rational)
-             `extR` (value :: F Char)
-             `extR` (value :: F Text)
-             `extR` (value :: F LT.Text)
-             `extR` (value :: F String)
-             `extR` (value :: F B.ByteString)
-             `extR` (value :: F LB.ByteString)
-             `extR` (value :: F Value)
-             `extR` (value :: F DotNetTime)
-             `extR` (value :: F UTCTime)
-             `extR` (value :: F IntSet)
-             `extR` (value :: F Bool)
-             `extR` (value :: F ())
-  where
-    value :: (FromJSON a) => Parser a
-    value = parseJSON j
-    list :: (Data a) => Parser [a]
-    list = V.toList <$> genericParseJSON j
-    vector :: (Data a) => Parser (V.Vector a)
-    vector = case j of
-               Array js -> V.mapM genericParseJSON js
-               _        -> myFail
-    mapAny :: forall e f. (Data e, Data f) => Parser (Map f e)
-    mapAny
-        | tyrep `elem` stringyTypes = res
-        | otherwise = myFail
-      where res = case j of
-                Object js -> M.mapKeysMonotonic trans <$> T.mapM genericParseJSON js
-                _         -> myFail
-            trans
-               | tyrep == typeOf T.empty  = remap id
-               | tyrep == typeOf LT.empty = remap LT.fromStrict
-               | tyrep == typeOf string   = remap T.unpack
-               | tyrep == typeOf B.empty  = remap encodeUtf8
-               | tyrep == typeOf LB.empty = remap lazy
-               | otherwise = modError "genericParseJSON"
-                                      "mapAny -- should never happen"
-            tyrep = typeOf (undefined :: f)
-            remap f = fromJust . cast . f
-    hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)
-    hashMapAny
-        | tyrep == typeOf string   = process T.unpack
-        | tyrep == typeOf LT.empty = process LT.fromStrict
-        | tyrep == typeOf T.empty  = process id
-        | otherwise = myFail
-      where
-        process f = maybe myFail return . cast =<< parseWith f
-        parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)
-        parseWith f = case j of
-                        Object js -> H.fromList . map (first f) . M.toList <$>
-                                     T.mapM genericParseJSON js
-                        _          -> myFail
-        tyrep = typeOf (undefined :: f)
-    myFail = modFail "genericParseJSON" $ "bad data: " ++ show j
-    stringyTypes = [typeOf LT.empty, typeOf T.empty, typeOf B.empty,
-                    typeOf LB.empty, typeOf string]
+instance (GToJSON a) => GProductToValues a where
+    gProductToValues = singleton . gToJSON
+    {-# INLINE gProductToValues #-}
 
-parseJSON_generic :: (Data a) => Value -> Parser a
-parseJSON_generic j = generic
-  where
-        typ = dataTypeOf $ resType generic
-        generic = case dataTypeRep typ of
-                    AlgRep []  -> case j of
-                                    Null -> return (modError "genericParseJSON" "empty type")
-                                    _ -> modFail "genericParseJSON" "no-constr bad data"
-                    AlgRep [_] -> decodeArgs (indexConstr typ 1) j
-                    AlgRep _   -> do (c, j') <- getConstr typ j; decodeArgs c j'
-                    rep        -> modFail "genericParseJSON" $
-                                  show rep ++ "(" ++ show typ ++ ")"
-        getConstr t (Object o) | [(s, j')] <- fromJSObject o = do
-                                                c <- readConstr' t s
-                                                return (c, j')
-        getConstr t (String js) = do c <- readConstr' t (unpack js)
-                                     return (c, Null) -- handle nullary ctor
-        getConstr _ _ = modFail "genericParseJSON" "bad constructor encoding"
-        readConstr' t s =
-          maybe (modFail "genericParseJSON" $ "unknown constructor: " ++ s ++ " " ++
-                         show t)
-                return $ readConstr t s
+--------------------------------------------------------------------------------
 
-        decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
-                           (constrFields c0)
-         where
-          go 0 c  _       Null       = construct c []   -- nullary constructor
-          go 1 c []       jd         = construct c [jd] -- unary constructor
-          go n c []       (Array js)
-              | n > 1 = construct c (V.toList js)   -- no field names
-          -- FIXME? We could allow reading an array into a constructor
-          -- with field names.
-          go _ c fs@(_:_) (Object o) = selectFields o fs >>=
-                                       construct c -- field names
-          go _ c _        jd         = modFail "genericParseJSON" $
-                                       "bad decodeArgs data " ++ show (c, jd)
+class GObject f where
+    gObject :: f a -> Object
 
-        fromJSObject = map (first unpack) . M.toList
+instance (GObject a, GObject b) => GObject (a :+: b) where
+    gObject (L1 x) = gObject x
+    gObject (R1 x) = gObject x
+    {-# INLINE gObject #-}
 
-        -- Build the value by stepping through the list of subparts.
-        construct c = evalStateT $ fromConstrM f c
-          where f :: (Data a) => StateT [Value] Parser a
-                f = do js <- get
-                       case js of
-                         [] -> lift $ modFail "construct" "empty list"
-                         (j':js') -> do put js'; lift $ genericParseJSON j'
+instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
+    gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
+    {-# INLINE gObject #-}
 
-        -- Select the named fields from a JSON object.
-        selectFields fjs = mapM sel
-          where sel f = maybe (modFail "genericParseJSON" $ "field does not exist " ++
-                               f) return $ M.lookup (pack f) fjs
+--------------------------------------------------------------------------------
+-- Generic parseJSON
 
-        -- Count how many arguments a constructor has.  The value x is
-        -- used to determine what type the constructor returns.
-        numConstrArgs :: (Data a) => a -> Constr -> Int
-        numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0
-          where f = do modify (+1); return undefined
+class GFromJSON f where
+    gParseJSON :: Value -> Parser (f a)
 
-        resType :: MonadPlus m => m a -> a
-        resType _ = modError "genericParseJSON" "resType"
+instance (GFromJSON a) => GFromJSON (M1 i c a) where
+    gParseJSON = fmap M1 . gParseJSON
+    {-# INLINE gParseJSON #-}
 
-modFail :: (Monad m) => String -> String -> m a
-modFail func err = fail $ "Data.Aeson.Types." ++ func ++ ": " ++ err
+instance (FromJSON a) => GFromJSON (K1 i a) where
+    gParseJSON = fmap K1 . parseJSON
+    {-# INLINE gParseJSON #-}
 
-modError :: String -> String -> a
-modError func err = error $ "Data.Aeson.Types." ++ func ++ ": " ++ err
+instance GFromJSON U1 where
+    gParseJSON v
+        | isEmptyArray v = pure U1
+        | otherwise      = typeMismatch "unit constructor (U1)" v
+    {-# INLINE gParseJSON #-}
 
-string :: String
-string = ""
+instance (ConsFromJSON a) => GFromJSON (C1 c a) where
+    gParseJSON = fmap M1 . consParseJSON
+    {-# INLINE gParseJSON #-}
 
--- Type extension for binary type constructors.
+instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
+    gParseJSON (Array arr) = gParseProduct arr
+    gParseJSON v = typeMismatch "product (:*:)" v
+    {-# INLINE gParseJSON #-}
 
--- | Flexible type extension
-ext2' :: (Data a, Typeable2 t)
-     => c a
-     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
-     -> c a
-ext2' def ext = maybe def id (dataCast2 ext)
+instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
+    gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
+    gParseJSON v = typeMismatch "sum (:+:)" v
+    {-# INLINE gParseJSON #-}
 
--- | Type extension of queries for type constructors
-ext2Q' :: (Data d, Typeable2 t)
-      => (d -> q)
-      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
-      -> d -> q
-ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
+--------------------------------------------------------------------------------
 
--- | Type extension of readers for type constructors
-ext2R' :: (Monad m, Data d, Typeable2 t)
-      => m d
-      -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
-      -> m d
-ext2R' def ext = unR ((R def) `ext2'` (R ext))
+class ConsFromJSON    f where consParseJSON  ::           Value -> Parser (f a)
+class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a))
 
--- | The type constructor for queries
-newtype Q q x = Q { unQ :: x -> q }
+instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where
+    consParseJSON = unTagged (consParseJSON' :: Tagged b (Value -> Parser (f a)))
+    {-# INLINE consParseJSON #-}
 
--- | The type constructor for readers
-newtype R m x = R { unR :: m x }
+instance (GFromRecord f) => ConsFromJSON' True f where
+    consParseJSON' = Tagged parseRecord
+        where
+          parseRecord (Object obj) = gParseRecord obj
+          parseRecord v = typeMismatch "record (:*:)" v
+    {-# INLINE consParseJSON' #-}
+
+instance (GFromJSON f) => ConsFromJSON' False f where
+    consParseJSON' = Tagged gParseJSON
+    {-# INLINE consParseJSON' #-}
+
+--------------------------------------------------------------------------------
+
+class GFromRecord f where
+    gParseRecord :: Object -> Parser (f a)
+
+instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
+    gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
+    {-# INLINE gParseRecord #-}
+
+instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
+    gParseRecord obj = case M.lookup (T.pack key) obj of
+                         Nothing -> notFound key
+                         Just v  -> gParseJSON v
+        where
+          key = selName (undefined :: t s a p)
+    {-# INLINE gParseRecord #-}
+
+--------------------------------------------------------------------------------
+
+class GFromProduct f where
+    gParseProduct :: Array -> Parser (f a)
+
+instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
+    gParseProduct arr = (:*:) <$> gParseProduct arrL <*> gParseProduct arrR
+        where
+          (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
+    {-# INLINE gParseProduct #-}
+
+instance (GFromJSON a) => GFromProduct a where
+    gParseProduct ((!? 0) -> Just v) = gParseJSON v
+    gParseProduct _ = fail "Array to small"
+    {-# INLINE gParseProduct #-}
+
+--------------------------------------------------------------------------------
+
+class GFromSum f where
+    gParseSum :: Pair -> Parser (f a)
+
+instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
+    gParseSum keyVal = (L1 <$> gParseSum keyVal) <|> (R1 <$> gParseSum keyVal)
+    {-# INLINE gParseSum #-}
+
+instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
+    gParseSum (key, value)
+        | key == pack (conName (undefined :: t c a p)) = gParseJSON value
+        | otherwise = notFound $ unpack key
+    {-# INLINE gParseSum #-}
+
+notFound :: String -> Parser a
+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
+
+--------------------------------------------------------------------------------
+
+newtype Tagged s b = Tagged {unTagged :: b}
+
+data True
+data False
+
+class IsRecord (f :: * -> *) b | f -> b
+
+instance (IsRecord f b) => IsRecord (f :*: g) b
+instance IsRecord (M1 S NoSelector f) False
+instance (IsRecord f b) => IsRecord (M1 S c f) b
+instance IsRecord (K1 i c) True
+instance IsRecord U1 False
+
+--------------------------------------------------------------------------------
+
+type DList a = [a] -> [a]
+
+toList :: DList a -> [a]
+toList = ($ [])
+{-# INLINE toList #-}
+
+singleton :: a -> DList a
+singleton = (:)
+{-# INLINE singleton #-}
+
+append :: DList a -> DList a -> DList a
+append = (.)
+{-# INLINE append #-}
+
+--------------------------------------------------------------------------------
+#endif
     template-haskell >= 2.4,
     time,
     unordered-containers >= 0.1.3.0,
-    vector >= 0.7
+    vector >= 0.7.1
 
   if flag(old-deepseq-containers)
     build-depends:
     ghc-prof-options: -auto-all
 
   if impl(ghc >= 7.2.1)
-    cpp-options: -DDEFAULT_SIGNATURES
+    cpp-options: -DGENERICS
+    build-depends: ghc-prim >= 0.2
 
   ghc-options:      -Wall
 

File benchmarks/AesonCompareAutoInstances.hs

+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell #-}
+
+module Main where
+
+--------------------------------------------------------------------------------
+
+import Criterion.Main
+
+import Control.DeepSeq (NFData, rnf, deepseq)
+
+import Data.Typeable (Typeable)
+import Data.Data (Data)
+import GHC.Generics (Generic)
+
+import Data.Aeson.Types
+import Data.Aeson.TH (mkToJSON, mkParseJSON)
+import qualified Data.Aeson.Generic as G (fromJSON, toJSON)
+
+--------------------------------------------------------------------------------
+
+-- Taken from the documentation of Data.Aeson.TH:
+data D a = Nullary
+         | Unary Int
+         | Product String Char a
+         | Record { testOne   :: Double
+                  , testTwo   :: Bool
+                  , testThree :: D a
+                  } deriving (Eq, Generic, Data, Typeable)
+
+instance NFData a => NFData (D a) where
+    rnf Nullary         = ()
+    rnf (Unary n)       = rnf n
+    rnf (Product s c x) = s `deepseq` c `deepseq` rnf x
+    rnf (Record d b y)  = d `deepseq` b `deepseq` rnf y
+
+type T = D (D (D ()))
+
+d :: T
+d = Record
+    { testOne = 1234.56789
+    , testTwo = True
+    , testThree = Product "Hello World!" 'a' $
+                    Record
+                    { testOne   = 9876.54321
+                    , testTwo   = False
+                    , testThree = Product "Yeehaa!!!" '\n' Nullary
+                    }
+    }
+
+instance ToJSON   a => ToJSON   (D a)
+instance FromJSON a => FromJSON (D a)
+
+thDToJSON :: ToJSON a => D a -> Value
+thDToJSON = $(mkToJSON id ''D)
+
+thDParseJSON :: FromJSON a => Value -> Parser (D a)
+thDParseJSON = $(mkParseJSON id ''D)
+
+thDFromJSON :: FromJSON a => Value -> Result (D a)
+thDFromJSON = parse thDParseJSON
+
+--------------------------------------------------------------------------------
+
+data BigRecord = BigRecord
+    { field01 :: !(), field02 :: !(), field03 :: !(), field04 :: !(), field05 :: !()
+    , field06 :: !(), field07 :: !(), field08 :: !(), field09 :: !(), field10 :: !()
+    , field11 :: !(), field12 :: !(), field13 :: !(), field14 :: !(), field15 :: !()
+    , field16 :: !(), field17 :: !(), field18 :: !(), field19 :: !(), field20 :: !()
+    , field21 :: !(), field22 :: !(), field23 :: !(), field24 :: !(), field25 :: !()
+    } deriving (Eq, Generic, Data, Typeable)
+
+instance NFData BigRecord
+
+bigRecord = BigRecord () () () () ()
+                      () () () () ()
+                      () () () () ()
+                      () () () () ()
+                      () () () () ()
+
+instance ToJSON   BigRecord
+instance FromJSON BigRecord
+
+thBigRecordToJSON :: BigRecord -> Value
+thBigRecordToJSON = $(mkToJSON id ''BigRecord)
+
+thBigRecordParseJSON :: Value -> Parser BigRecord
+thBigRecordParseJSON = $(mkParseJSON id ''BigRecord)
+
+thBigRecordFromJSON :: Value -> Result BigRecord
+thBigRecordFromJSON = parse thBigRecordParseJSON
+
+--------------------------------------------------------------------------------
+
+data BigProduct = BigProduct
+    !() !() !() !() !()
+    !() !() !() !() !()
+    !() !() !() !() !()
+    !() !() !() !() !()
+    !() !() !() !() !()
+    deriving (Eq, Generic, Data, Typeable)
+
+instance NFData BigProduct
+
+bigProduct = BigProduct () () () () ()
+                        () () () () ()
+                        () () () () ()
+                        () () () () ()
+                        () () () () ()
+
+instance ToJSON   BigProduct
+instance FromJSON BigProduct
+
+thBigProductToJSON :: BigProduct -> Value
+thBigProductToJSON = $(mkToJSON id ''BigProduct)
+
+thBigProductParseJSON :: Value -> Parser BigProduct
+thBigProductParseJSON = $(mkParseJSON id ''BigProduct)
+
+thBigProductFromJSON :: Value -> Result BigProduct
+thBigProductFromJSON = parse thBigProductParseJSON
+
+--------------------------------------------------------------------------------
+
+data BigSum = F01 | F02 | F03 | F04 | F05
+            | F06 | F07 | F08 | F09 | F10
+            | F11 | F12 | F13 | F14 | F15
+            | F16 | F17 | F18 | F19 | F20
+            | F21 | F22 | F23 | F24 | F25
+    deriving (Eq, Generic, Data, Typeable)
+
+instance NFData BigSum
+
+bigSum = F12
+
+instance ToJSON   BigSum
+instance FromJSON BigSum
+
+thBigSumToJSON :: BigSum -> Value
+thBigSumToJSON = $(mkToJSON id ''BigSum)
+
+thBigSumParseJSON :: Value -> Parser BigSum
+thBigSumParseJSON = $(mkParseJSON id ''BigSum)
+
+thBigSumFromJSON :: Value -> Result BigSum
+thBigSumFromJSON = parse thBigSumParseJSON
+
+--------------------------------------------------------------------------------
+
+type FJ a = Value -> Result a
+
+main :: IO ()
+main = defaultMain
+  [ let v = thDToJSON d
+    in d `deepseq` v `deepseq`
+       bgroup "D"
+       [ group "toJSON"   (nf thDToJSON d)
+                          (nf G.toJSON  d)
+                          (nf toJSON    d)
+       , group "fromJSON" (nf (thDFromJSON :: FJ T) v)
+                          (nf (G.fromJSON  :: FJ T) v)
+                          (nf (fromJSON    :: FJ T) v)
+       ]
+  , let v = thBigRecordToJSON bigRecord
+    in bigRecord `deepseq` v `deepseq`
+       bgroup "BigRecord"
+       [ group "toJSON"   (nf thBigRecordToJSON bigRecord)
+                          (nf G.toJSON          bigRecord)
+                          (nf toJSON            bigRecord)
+       , group "fromJSON" (nf (thBigRecordFromJSON :: FJ BigRecord) v)
+                          (nf (G.fromJSON          :: FJ BigRecord) v)
+                          (nf (fromJSON            :: FJ BigRecord) v)
+       ]
+  , let v = thBigProductToJSON bigProduct
+    in bigProduct `deepseq` v `deepseq`
+       bgroup "BigProduct"
+       [ group "toJSON"   (nf thBigProductToJSON bigProduct)
+                          (nf G.toJSON           bigProduct)
+                          (nf toJSON             bigProduct)
+       , group "fromJSON" (nf (thBigProductFromJSON :: FJ BigProduct) v)
+                          (nf (G.fromJSON           :: FJ BigProduct) v)
+                          (nf (fromJSON             :: FJ BigProduct) v)
+       ]
+  , let v = thBigSumToJSON bigSum
+    in bigSum `deepseq` v `deepseq`
+       bgroup "BigSum"
+       [ group "toJSON"   (nf thBigSumToJSON bigSum)
+                          (nf G.toJSON       bigSum)
+                          (nf toJSON         bigSum)
+       , group "fromJSON" (nf (thBigSumFromJSON :: FJ BigSum) v)
+                          (nf (G.fromJSON       :: FJ BigSum) v)
+                          (nf (fromJSON         :: FJ BigSum) v)
+       ]
+  ]
+
+group n th syb gen = bgroup n [ bench "th"      th
+                              , bench "syb"     syb
+                              , bench "generic" gen
+                              ]

File benchmarks/Makefile

 ghc := ghc
 ghcflags := -O
 
-binaries := AesonParse AesonEncode JsonParse
+binaries := AesonParse AesonEncode JsonParse AesonCompareAutoInstances
 
 all: $(binaries) $(binaries:%=%_p)