SmallRecord.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}

module Main (main) where

import Prelude ()
import Prelude.Compat

import Control.Monad
import Control.DeepSeq (NFData, rnf, deepseq)
#ifndef DONTRUN
import Criterion.Main hiding (defaultOptions)
#endif
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
import GHC.Exts

toBS :: Encoding -> ByteString
toBS = encodingToLazyByteString

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

data BigRecord = BigRecord
    { field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int
    } deriving (Show, Eq, Generic)

instance NFData BigRecord

bigRecord = BigRecord 1   2  3  4  5

return []

gBigRecordToJSON :: BigRecord -> Value
gBigRecordToJSON = genericToJSON opts

gBigRecordEncode :: BigRecord -> ByteString
gBigRecordEncode = gEncode

#ifdef DONTRUN
{-# NOINLINE gBigRecordEncode #-}
{-# NOINLINE thBigRecordEncode #-}
#endif

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)

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

type FJ a = Value -> Result a

runBench :: IO ()
#ifndef DONTRUN
runBench = defaultMain
  [ 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)
       ]
  ]

group n th gen = bgroup n [ bench "th"      th
                          , bench "generic" gen
                          ]
#else
runBench = return ()
#endif

sanityCheck = do
  check bigRecord thBigRecordToJSON thBigRecordFromJSON thBigRecordEncode
  check bigRecord gBigRecordToJSON gBigRecordFromJSON gBigRecordEncode

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