-- Adapted from a buffer-builder benchmark:
--
-- https://github.com/chadaustin/buffer-builder/blob/master/test.json
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Compare.JsonBench (benchmarks) where
import Prelude ()
import Prelude.Compat
import Control.DeepSeq (NFData(..))
import Criterion
import Data.Aeson ((.:))
import Data.Monoid ((<>))
import Data.Text (Text)
import Typed.Common (load)
import qualified Data.Aeson as Aeson
import qualified Data.BufferBuilder.Json as Json
import qualified Data.Json.Builder as JB
data EyeColor = Green | Blue | Brown
deriving (Eq, Show)
data Gender = Male | Female
deriving (Eq, Show)
data Fruit = Apple | Strawberry | Banana
deriving (Eq, Show)
data Friend = Friend
{ fId :: !Int
, fName :: !Text
} deriving (Eq, Show)
data User = User
{ uId :: !Text
, uIndex :: !Int
, uGuid :: !Text
, uIsActive :: !Bool
, uBalance :: !Text
, uPicture :: !Text
, uAge :: !Int
, uEyeColor :: !EyeColor
, uName :: !Text
, uGender :: !Gender
, uCompany :: !Text
, uEmail :: !Text
, uPhone :: !Text
, uAddress :: !Text
, uAbout :: !Text
, uRegistered :: !Text -- UTCTime?
, uLatitude :: !Double
, uLongitude :: !Double
, uTags :: ![Text]
, uFriends :: ![Friend]
, uGreeting :: !Text
, uFavouriteFruit :: !Fruit
} deriving (Eq, Show)
instance NFData EyeColor where rnf !_ = ()
instance NFData Gender where rnf !_ = ()
instance NFData Fruit where rnf !_ = ()
instance NFData Friend where
rnf Friend {..} = rnf fId `seq` rnf fName `seq` ()
instance NFData User where
rnf User {..} = rnf uId `seq` rnf uIndex `seq` rnf uGuid `seq` rnf uIsActive `seq` rnf uBalance `seq` rnf uPicture `seq` rnf uAge `seq` rnf uEyeColor `seq` rnf uName `seq` rnf uGender `seq` rnf uCompany `seq` rnf uEmail `seq` rnf uPhone `seq` rnf uAddress `seq` rnf uAbout `seq` rnf uRegistered `seq` rnf uLatitude `seq` rnf uLongitude `seq` rnf uTags `seq` rnf uFriends `seq` rnf uGreeting `seq` rnf uFavouriteFruit `seq` ()
eyeColorTable :: [(Text, EyeColor)]
eyeColorTable = [("brown", Brown), ("green", Green), ("blue", Blue)]
genderTable :: [(Text, Gender)]
genderTable = [("male", Male), ("female", Female)]
fruitTable :: [(Text, Fruit)]
fruitTable = [("apple", Apple), ("strawberry", Strawberry), ("banana", Banana)]
enumFromJson :: Monad m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum
enumFromJson enumName table extract v = do
s <- extract v
case lookup s table of
Just r -> return r
Nothing -> fail $ "Bad " ++ enumName ++ ": " ++ show s
--- Aeson instances ---
instance Aeson.FromJSON EyeColor where
parseJSON = enumFromJson "EyeColor" eyeColorTable Aeson.parseJSON
instance Aeson.FromJSON Gender where
parseJSON = enumFromJson "Gender" genderTable Aeson.parseJSON
instance Aeson.FromJSON Fruit where
parseJSON = enumFromJson "Fruit" fruitTable Aeson.parseJSON
instance Aeson.FromJSON Friend where
parseJSON = Aeson.withObject "Friend" $ \o -> do
fId <- o .: "id"
fName <- o .: "name"
return Friend {..}
instance Aeson.FromJSON User where
parseJSON = Aeson.withObject "User" $ \o -> do
uId <- o .: "_id"
uIndex <- o .: "index"
uGuid <- o .: "guid"
uIsActive <- o .: "isActive"
uBalance <- o .: "balance"
uPicture <- o .: "picture"
uAge <- o .: "age"
uEyeColor <- o .: "eyeColor"
uName <- o .: "name"
uGender <- o .: "gender"
uCompany <- o .: "company"
uEmail <- o .: "email"
uPhone <- o .: "phone"
uAddress <- o .: "address"
uAbout <- o .: "about"
uRegistered <- o .: "registered"
uLatitude <- o .: "latitude"
uLongitude <- o .: "longitude"
uTags <- o .: "tags"
uFriends <- o .: "friends"
uGreeting <- o .: "greeting"
uFavouriteFruit <- o .: "favoriteFruit"
return User {..}
instance Aeson.ToJSON EyeColor where
toJSON ec = Aeson.toJSON $ case ec of
Green -> "green" :: Text
Blue -> "blue"
Brown -> "brown"
toEncoding ec = Aeson.toEncoding $ case ec of
Green -> "green" :: Text
Blue -> "blue"
Brown -> "brown"
instance Aeson.ToJSON Gender where
toJSON g = Aeson.toJSON $ case g of
Male -> "male" :: Text
Female -> "female"
toEncoding g = Aeson.toEncoding $ case g of
Male -> "male" :: Text
Female -> "female"
instance Aeson.ToJSON Fruit where
toJSON f = Aeson.toJSON $ case f of
Apple -> "apple" :: Text
Banana -> "banana"
Strawberry -> "strawberry"
toEncoding f = Aeson.toEncoding $ case f of
Apple -> "apple" :: Text
Banana -> "banana"
Strawberry -> "strawberry"
instance Aeson.ToJSON Friend where
toJSON Friend {..} = Aeson.object
[ "id" Aeson..= fId
, "name" Aeson..= fName
]
toEncoding Friend {..} = Aeson.pairs $
"id" Aeson..= fId
<> "name" Aeson..= fName
instance Aeson.ToJSON User where
toJSON User{..} = Aeson.object
[ "_id" Aeson..= uId
, "index" Aeson..= uIndex
, "guid" Aeson..= uGuid
, "isActive" Aeson..= uIsActive
, "balance" Aeson..= uBalance
, "picture" Aeson..= uPicture
, "age" Aeson..= uAge
, "eyeColor" Aeson..= uEyeColor
, "name" Aeson..= uName
, "gender" Aeson..= uGender
, "company" Aeson..= uCompany
, "email" Aeson..= uEmail
, "phone" Aeson..= uPhone
, "address" Aeson..= uAddress
, "about" Aeson..= uAbout
, "registered" Aeson..= uRegistered
, "latitude" Aeson..= uLatitude
, "longitude" Aeson..= uLongitude
, "tags" Aeson..= uTags
, "friends" Aeson..= uFriends
, "greeting" Aeson..= uGreeting
, "favoriteFruit" Aeson..= uFavouriteFruit
]
toEncoding User{..} = Aeson.pairs $
"_id" Aeson..= uId
<> "index" Aeson..= uIndex
<> "guid" Aeson..= uGuid
<> "isActive" Aeson..= uIsActive
<> "balance" Aeson..= uBalance
<> "picture" Aeson..= uPicture
<> "age" Aeson..= uAge
<> "eyeColor" Aeson..= uEyeColor
<> "name" Aeson..= uName
<> "gender" Aeson..= uGender
<> "company" Aeson..= uCompany
<> "email" Aeson..= uEmail
<> "phone" Aeson..= uPhone
<> "address" Aeson..= uAddress
<> "about" Aeson..= uAbout
<> "registered" Aeson..= uRegistered
<> "latitude" Aeson..= uLatitude
<> "longitude" Aeson..= uLongitude
<> "tags" Aeson..= uTags
<> "friends" Aeson..= uFriends
<> "greeting" Aeson..= uGreeting
<> "favoriteFruit" Aeson..= uFavouriteFruit
--- BufferBuilder instances ---
instance Json.ToJson EyeColor where
toJson ec = Json.toJson $ case ec of
Green -> "green" :: Text
Blue -> "blue"
Brown -> "brown"
instance Json.ToJson Gender where
toJson g = Json.toJson $ case g of
Male -> "male" :: Text
Female -> "female"
instance Json.ToJson Fruit where
toJson f = Json.toJson $ case f of
Apple -> "apple" :: Text
Strawberry -> "strawberry"
Banana -> "banana"
instance Json.ToJson Friend where
toJson Friend{..} = Json.toJson $
"_id" Json..= fId
<> "name" Json..= fName
instance Json.ToJson User where
toJson User{..} = Json.toJson $
"_id"# Json..=# uId
<> "index"# Json..=# uIndex
<> "guid"# Json..=# uGuid
<> "isActive"# Json..=# uIsActive
<> "balance"# Json..=# uBalance
<> "picture"# Json..=# uPicture
<> "age"# Json..=# uAge
<> "eyeColor"# Json..=# uEyeColor
<> "name"# Json..=# uName
<> "gender"# Json..=# uGender
<> "company"# Json..=# uCompany
<> "email"# Json..=# uEmail
<> "phone"# Json..=# uPhone
<> "address"# Json..=# uAddress
<> "about"# Json..=# uAbout
<> "registered"# Json..=# uRegistered
<> "latitude"# Json..=# uLatitude
<> "longitude"# Json..=# uLongitude
<> "tags"# Json..=# uTags
<> "friends"# Json..=# uFriends
<> "greeting"# Json..=# uGreeting
<> "favoriteFruit"# Json..=# uFavouriteFruit
---- json-builder instances ----
instance JB.Value EyeColor where
toJson ec = JB.toJson $ case ec of
Green -> "green" :: Text
Blue -> "blue"
Brown -> "brown"
instance JB.Value Gender where
toJson g = JB.toJson $ case g of
Male -> "male" :: Text
Female -> "female"
instance JB.Value Fruit where
toJson f = JB.toJson $ case f of
Apple -> "apple" :: Text
Strawberry -> "strawberry"
Banana -> "banana"
instance JB.Value Friend where
toJson Friend{..} = JB.toJson $
("_id" :: Text) `JB.row` fId
<> ("name" :: Text) `JB.row` fName
instance JB.Value User where
toJson User{..} =
let t :: Text -> Text
t = id
in JB.toJson $
t "_id" `JB.row` uId
<> t "index" `JB.row` uIndex
<> t "guid" `JB.row` uGuid
<> t "isActive" `JB.row` uIsActive
<> t "balance" `JB.row` uBalance
<> t "picture" `JB.row` uPicture
<> t "age" `JB.row` uAge
<> t "eyeColor" `JB.row` uEyeColor
<> t "name" `JB.row` uName
<> t "gender" `JB.row` uGender
<> t "company" `JB.row` uCompany
<> t "email" `JB.row` uEmail
<> t "phone" `JB.row` uPhone
<> t "address" `JB.row` uAddress
<> t "about" `JB.row` uAbout
<> t "registered" `JB.row` uRegistered
<> t "latitude" `JB.row` uLatitude
<> t "longitude" `JB.row` uLongitude
<> t "tags" `JB.row` uTags
<> t "friends" `JB.row` uFriends
<> t "greeting" `JB.row` uGreeting
<> t "favoriteFruit" `JB.row` uFavouriteFruit
benchmarks :: Benchmark
benchmarks = env (load "json-data/buffer-builder.json") $
\ ~(parsedUserList :: [User]) ->
bgroup "json-bench" [
bench "aeson" $ nf Aeson.encode parsedUserList
, bench "buffer-builder" $ nf Json.encodeJson parsedUserList
, bench "json-builder" $ nf JB.toJsonLBS parsedUserList
]