{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
module Main (main) where
import Prelude ()
import Prelude.Compat
import Control.Monad
import Control.DeepSeq (NFData, rnf, deepseq)
import Criterion.Main hiding (defaultOptions)
import Data.Aeson
import Data.Aeson.Encoding
import Data.Aeson.TH
import Data.Aeson.Types
import Data.ByteString.Lazy (ByteString)
import Data.Data (Data)
import Data.Typeable (Typeable)
import GHC.Generics (Generic, Rep)
import Options
toBS :: Encoding -> ByteString
toBS = encodingToLazyByteString
gEncode :: (Generic a, GToEncoding Zero (Rep a)) => a -> ByteString
gEncode = toBS . genericToEncoding opts
--------------------------------------------------------------------------------
data D a = Nullary
| Unary Int
| Product String Char a
| Record { testOne :: Double
, testTwo :: Bool
, testThree :: D a
}
deriving (Show, Eq)
deriveJSON opts ''D
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
}
}
--------------------------------------------------------------------------------
data D' a = Nullary'
| Unary' Int
| Product' String Char a
| Record' { testOne' :: Double
, testTwo' :: Bool
, testThree' :: D' a
}
deriving (Show, Eq, Generic)
instance ToJSON a => ToJSON (D' a) where
toJSON = genericToJSON opts
instance FromJSON a => FromJSON (D' a) where
parseJSON = genericParseJSON opts
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'
}
}
--------------------------------------------------------------------------------
data BigRecord = BigRecord
{ field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int
, field06 :: !Int, field07 :: !Int, field08 :: !Int, field09 :: !Int, field10 :: !Int
, field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int
, field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int
, field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int
} deriving (Show, Eq, Generic)
instance NFData BigRecord
bigRecord = BigRecord 1 2 3 4 5
6 7 8 9 10
11 12 13 14 15
16 17 18 19 20
21 22 23 24 25
return []
gBigRecordToJSON :: BigRecord -> Value
gBigRecordToJSON = genericToJSON opts
gBigRecordEncode :: BigRecord -> ByteString
gBigRecordEncode = gEncode
gBigRecordFromJSON :: Value -> Result BigRecord
gBigRecordFromJSON = parse $ genericParseJSON opts
thBigRecordToJSON :: BigRecord -> Value
thBigRecordToJSON = $(mkToJSON opts ''BigRecord)
thBigRecordEncode :: BigRecord -> ByteString
thBigRecordEncode = toBS . $(mkToEncoding opts ''BigRecord)
thBigRecordFromJSON :: Value -> Result BigRecord
thBigRecordFromJSON = parse $(mkParseJSON opts ''BigRecord)
--------------------------------------------------------------------------------
data BigProduct = BigProduct
!Int !Int !Int !Int !Int
!Int !Int !Int !Int !Int
!Int !Int !Int !Int !Int
!Int !Int !Int !Int !Int
!Int !Int !Int !Int !Int
deriving (Show, Eq, Generic)
instance NFData BigProduct
bigProduct = BigProduct 1 2 3 4 5
6 7 8 9 10
11 12 13 14 15
16 17 18 19 20
21 22 23 24 25
return []
gBigProductToJSON :: BigProduct -> Value
gBigProductToJSON = genericToJSON opts
gBigProductEncode :: BigProduct -> ByteString
gBigProductEncode = gEncode
gBigProductFromJSON :: Value -> Result BigProduct
gBigProductFromJSON = parse $ genericParseJSON opts
thBigProductToJSON :: BigProduct -> Value
thBigProductToJSON = $(mkToJSON opts ''BigProduct)
thBigProductEncode :: BigProduct -> ByteString
thBigProductEncode = toBS . $(mkToEncoding opts ''BigProduct)
thBigProductFromJSON :: Value -> Result BigProduct
thBigProductFromJSON = parse $(mkParseJSON opts ''BigProduct)
--------------------------------------------------------------------------------
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 (Show, Eq, Generic)
instance NFData BigSum
bigSum = F25
return []
gBigSumToJSON :: BigSum -> Value
gBigSumToJSON = genericToJSON opts
gBigSumEncode :: BigSum -> ByteString
gBigSumEncode = gEncode
gBigSumFromJSON :: Value -> Result BigSum
gBigSumFromJSON = parse $ genericParseJSON opts
thBigSumToJSON :: BigSum -> Value
thBigSumToJSON = $(mkToJSON opts ''BigSum)
thBigSumEncode :: BigSum -> ByteString
thBigSumEncode = toBS . $(mkToEncoding opts ''BigSum)
thBigSumFromJSON :: Value -> Result BigSum
thBigSumFromJSON = parse $(mkParseJSON opts ''BigSum)
--------------------------------------------------------------------------------
type FJ a = Value -> Result a
runBench :: IO ()
runBench = defaultMain
[ let v = toJSON d
in (d, d', v) `deepseq`
bgroup "D"
[ group "toJSON" (nf toJSON d)
(nf toJSON d')
, group "encode" (nf encode d)
(nf encode d')
, group "fromJSON" (nf ( 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 gBigRecordToJSON bigRecord)
, group "encode" (nf thBigRecordEncode bigRecord)
(nf gBigRecordEncode bigRecord)
, group "fromJSON" (nf (thBigRecordFromJSON :: FJ BigRecord) v)
(nf ( gBigRecordFromJSON :: FJ BigRecord) v)
]
, let v = thBigProductToJSON bigProduct
in bigProduct `deepseq` v `deepseq`
bgroup "BigProduct"
[ group "toJSON" (nf thBigProductToJSON bigProduct)
(nf gBigProductToJSON bigProduct)
, group "encode" (nf thBigProductEncode bigProduct)
(nf gBigProductEncode bigProduct)
, group "fromJSON" (nf (thBigProductFromJSON :: FJ BigProduct) v)
(nf (gBigProductFromJSON :: FJ BigProduct) v)
]
, let v = thBigSumToJSON bigSum
in bigSum `deepseq` v `deepseq`
bgroup "BigSum"
[ group "toJSON" (nf thBigSumToJSON bigSum)
(nf gBigSumToJSON bigSum)
, group "encode" (nf thBigSumEncode bigSum)
(nf gBigSumEncode bigSum)
, group "fromJSON" (nf (thBigSumFromJSON :: FJ BigSum) v)
(nf (gBigSumFromJSON :: FJ BigSum) v)
]
]
group n th gen = bgroup n [ bench "th" th
, bench "generic" gen
]
sanityCheck = do
check d toJSON fromJSON encode
check d' toJSON fromJSON encode
check bigRecord thBigRecordToJSON thBigRecordFromJSON thBigRecordEncode
check bigRecord gBigRecordToJSON gBigRecordFromJSON gBigRecordEncode
check bigProduct thBigProductToJSON thBigProductFromJSON thBigProductEncode
check bigProduct gBigProductToJSON gBigProductFromJSON gBigProductEncode
check bigSum thBigSumToJSON thBigSumFromJSON thBigSumEncode
check bigSum gBigSumToJSON gBigSumFromJSON gBigSumEncode
check :: (Show a, Eq a)
=> a -> (a -> Value) -> (Value -> Result a) -> (a -> ByteString) -> IO ()
check x toJSON fromJSON encode = do
unless (Success x == (fromJSON . toJSON) x) $ fail $ "toJSON: " ++ show x
unless (Success x == (decode' . encode) x) $ fail $ "encode: " ++ show x
where
decode' s = case decode s of
Just v -> fromJSON v
Nothing -> fail ""
main = do
sanityCheck
runBench