Skip to content

Commit

Permalink
Update generic benchmark
Browse files Browse the repository at this point in the history
  • Loading branch information
@Lysxia
Lysxia committed Mar 29, 2017
1 parent 19e3efe commit 55b360d
Show file tree
Hide file tree
Showing 2 changed files with 81 additions and 28 deletions.
107 changes: 80 additions & 27 deletions benchmarks/AesonCompareAutoInstances.hs
View file
@@ -1,22 +1,30 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# 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.Encode
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)
import GHC.Generics (Generic, Rep)
import Options
import qualified Data.Aeson.Generic as G (fromJSON, toJSON)

toBS :: Encoding -> ByteString
toBS = encodingToLazyByteString

gEncode :: (Generic a, GToEncoding Zero (Rep a)) => a -> ByteString
gEncode = toBS . genericToEncoding opts

--------------------------------------------------------------------------------

Expand All @@ -27,7 +35,7 @@ data D a = Nullary
, testTwo :: Bool
, testThree :: D a
}
deriving (Show, Eq, Data, Typeable)
deriving (Show, Eq)

deriveJSON opts ''D

Expand Down Expand Up @@ -60,7 +68,7 @@ data D' a = Nullary'
, testTwo' :: Bool
, testThree' :: D' a
}
deriving (Show, Eq, Generic, Data, Typeable)
deriving (Show, Eq, Generic)

instance ToJSON a => ToJSON (D' a) where
toJSON = genericToJSON opts
Expand Down Expand Up @@ -96,7 +104,7 @@ data BigRecord = BigRecord
, 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, Data, Typeable)
} deriving (Show, Eq, Generic)

instance NFData BigRecord

Expand All @@ -106,15 +114,23 @@ bigRecord = BigRecord 1 2 3 4 5
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)

Expand All @@ -126,7 +142,7 @@ data BigProduct = BigProduct
!Int !Int !Int !Int !Int
!Int !Int !Int !Int !Int
!Int !Int !Int !Int !Int
deriving (Show, Eq, Generic, Data, Typeable)
deriving (Show, Eq, Generic)

instance NFData BigProduct

Expand All @@ -136,15 +152,23 @@ bigProduct = BigProduct 1 2 3 4 5
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)

Expand All @@ -155,75 +179,104 @@ data BigSum = F01 | F02 | F03 | F04 | F05
| F11 | F12 | F13 | F14 | F15
| F16 | F17 | F18 | F19 | F20
| F21 | F22 | F23 | F24 | F25
deriving (Show, Eq, Generic, Data, Typeable)
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

main :: IO ()
main = defaultMain
runBench :: IO ()
runBench = defaultMain
[ let v = toJSON d
in (d, d', v) `deepseq`
bgroup "D"
[ group "toJSON" (nf toJSON d)
(nf G.toJSON d)
(nf toJSON d')
, group "encode" (nf encode d)
(nf encode d')
, group "fromJSON" (nf ( fromJSON :: 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 gBigRecordToJSON bigRecord)
(nf gBigRecordToJSON bigRecord)
, group "encode" (nf thBigRecordEncode bigRecord)
(nf gBigRecordEncode bigRecord)
, group "fromJSON" (nf (thBigRecordFromJSON :: FJ BigRecord) v)
(nf (G.fromJSON :: FJ BigRecord) v)
(nf (gBigRecordFromJSON :: 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 G.toJSON bigProduct)
(nf gBigProductToJSON bigProduct)
, group "encode" (nf thBigProductEncode bigProduct)
(nf gBigProductEncode bigProduct)
, group "fromJSON" (nf (thBigProductFromJSON :: FJ BigProduct) v)
(nf (G.fromJSON :: 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 G.toJSON bigSum)
(nf gBigSumToJSON bigSum)
, group "encode" (nf thBigSumEncode bigSum)
(nf gBigSumEncode bigSum)
, group "fromJSON" (nf (thBigSumFromJSON :: FJ BigSum) v)
(nf (G.fromJSON :: FJ BigSum) v)
(nf (gBigSumFromJSON :: FJ BigSum) v)
]
]

group n th syb gen = bcompare
[ bgroup n [ bench "th" th
, bench "syb" syb
, bench "generic" gen
]
]
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
2 changes: 1 addition & 1 deletion benchmarks/Options.hs
View file
@@ -1,4 +1,4 @@
module Options () where
module Options where

import Prelude ()
import Prelude.Compat
Expand Down

0 comments on commit 55b360d

Please sign in to comment.