{-# LANGUAGE CPP, ExistentialQuantification #-}
{-# LANGUAGE DeriveGeneric #-}

module Main (main) where

import Control.DeepSeq
import Control.Exception (evaluate)
import Criterion.Main
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import Data.Monoid

import GHC.Generics

import Data.Binary
import Data.Binary.Put
import Data.ByteString.Builder as BB
import Prelude -- Silence Monoid import warning.

main :: IO ()
main = do
  evaluate $ rnf
    [ rnf bigIntegers
    , rnf smallIntegers
    , rnf smallByteStrings
    , rnf smallStrings
    , rnf doubles
    , rnf word8s
    , rnf word16s
    , rnf word32s
    , rnf word64s
    ]
  defaultMain
    [
      bench "small Integers" $ whnf (run . fromIntegers) smallIntegers,
      bench "big Integers" $ whnf (run . fromIntegers) bigIntegers,

      bench "[small Integer]" $ whnf (run . put) smallIntegers,
      bench "[big Integer]" $ whnf (run . put) bigIntegers,

      bench "small ByteStrings" $ whnf (run . fromByteStrings) smallByteStrings,
      bench "[small ByteString]" $ whnf (run . put) smallByteStrings,

      bench "small Strings" $ whnf (run . fromStrings) smallStrings,
      bench "[small String]" $ whnf (run . put) smallStrings,

      bench "Double" $ whnf (run . put) doubles,

      bench "Word8s monoid put" $ whnf (run . fromWord8s) word8s,
      bench "Word8s builder" $ whnf (L.length . toLazyByteString . fromWord8sBuilder) word8s,
      bench "[Word8]" $ whnf (run . put) word8s,
      bench "Word16s monoid put" $ whnf (run . fromWord16s) word16s,
      bench "Word16s builder" $ whnf (L.length . toLazyByteString . fromWord16sBuilder) word16s,
      bench "[Word16]" $ whnf (run . put) word16s,
      bench "Word32s monoid put" $ whnf (run . fromWord32s) word32s,
      bench "Word32s builder" $ whnf (L.length . toLazyByteString . fromWord32sBuilder) word32s,
      bench "[Word32]" $ whnf (run . put) word32s,
      bench "Word64s monoid put" $ whnf (run . fromWord64s) word64s,
      bench "Word64s builder" $ whnf (L.length . toLazyByteString . fromWord64sBuilder) word64s,
      bench "[Word64]" $ whnf (run . put) word64s

      , bgroup "Generics" [
        bench "Struct monoid put" $ whnf (run . fromStructs) structs,
        bench "Struct put as list" $ whnf (run . put) structs,
        bench "StructList monoid put" $ whnf (run . fromStructLists) structLists,
        bench "StructList put as list" $ whnf (run . put) structLists
      ]
    ]
  where
    run = L.length . runPut

data Struct = Struct Word8 Word16 Word32 Word64 deriving Generic
instance Binary Struct

data StructList = StructList [Struct] deriving Generic
instance Binary StructList

structs :: [Struct]
structs = take 10000 $ [ Struct a b 0 0 | a <- [0 .. maxBound], b <- [0 .. maxBound] ]

structLists :: [StructList]
structLists = replicate 1000 (StructList (take 10 structs))

-- Input data

smallIntegers :: [Integer]
smallIntegers = [0..10000]
{-# NOINLINE smallIntegers #-}

bigIntegers :: [Integer]
bigIntegers = [m .. m + 10000]
  where
    m :: Integer
    m = fromIntegral (maxBound :: Word64)
{-# NOINLINE bigIntegers #-}

smallByteStrings :: [S.ByteString]
smallByteStrings = replicate 10000 $ C.pack "abcdefghi"
{-# NOINLINE smallByteStrings #-}

smallStrings :: [String]
smallStrings = replicate 10000 "abcdefghi"
{-# NOINLINE smallStrings #-}

doubles :: [Double]
doubles = take 10000 $ [ sign * 2 ** n | sign <- [-1, 1], n <- [ 0, 0.2 .. 1023 ]]

word8s :: [Word8]
word8s = take 10000 $ cycle [minBound .. maxBound]
{-# NOINLINE word8s #-}

word16s :: [Word16]
word16s = take 10000 $ cycle [minBound .. maxBound]
{-# NOINLINE word16s #-}

word32s :: [Word32]
word32s = take 10000 $ cycle [minBound .. maxBound]
{-# NOINLINE word32s #-}

word64s :: [Word64]
word64s = take 10000 $ cycle [minBound .. maxBound]
{-# NOINLINE word64s #-}

------------------------------------------------------------------------
-- Benchmarks

fromIntegers :: [Integer] -> Put
fromIntegers [] = mempty
fromIntegers (x:xs) = put x `mappend` fromIntegers xs

fromByteStrings :: [S.ByteString] -> Put
fromByteStrings [] = mempty
fromByteStrings (x:xs) = put x `mappend` fromByteStrings xs

fromStrings :: [String] -> Put
fromStrings [] = mempty
fromStrings (x:xs) = put x `mappend` fromStrings xs

fromWord8s :: [Word8] -> Put
fromWord8s [] = mempty
fromWord8s (x:xs) = put x `mappend` fromWord8s xs

fromWord8sBuilder :: [Word8] -> BB.Builder
fromWord8sBuilder [] = mempty
fromWord8sBuilder (x:xs) = BB.word8 x `mappend` fromWord8sBuilder xs

fromWord16s :: [Word16] -> Put
fromWord16s [] = mempty
fromWord16s (x:xs) = put x `mappend` fromWord16s xs

fromWord16sBuilder :: [Word16] -> BB.Builder
fromWord16sBuilder [] = mempty
fromWord16sBuilder (x:xs) = BB.word16BE x `mappend` fromWord16sBuilder xs

fromWord32s :: [Word32] -> Put
fromWord32s [] = mempty
fromWord32s (x:xs) = put x `mappend` fromWord32s xs

fromWord32sBuilder :: [Word32] -> BB.Builder
fromWord32sBuilder [] = mempty
fromWord32sBuilder (x:xs) = BB.word32BE x `mappend` fromWord32sBuilder xs

fromWord64s :: [Word64] -> Put
fromWord64s [] = mempty
fromWord64s (x:xs) = put x `mappend` fromWord64s xs

fromWord64sBuilder :: [Word64] -> BB.Builder
fromWord64sBuilder [] = mempty
fromWord64sBuilder (x:xs) = BB.word64BE x `mappend` fromWord64sBuilder xs

fromStructs :: [Struct] -> Put
fromStructs [] = mempty
fromStructs (x:xs) = put x `mappend` fromStructs xs

fromStructLists :: [StructList] -> Put
fromStructLists [] = mempty
fromStructLists (x:xs) = put x `mappend` fromStructLists xs