{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE DeriveDataTypeable #-}
import Control.Applicative ((<$>), (<*>), (*>))
#endif

import           Control.DeepSeq
import           Criterion.Main
import qualified Data.ByteString as BS
import           Data.Int
import qualified Data.IntMap.Strict as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import           Data.Store
import           Data.Typeable
import qualified Data.Vector as V
import qualified Data.Vector.Storable as SV
import           Data.Word
import           GHC.Generics

#if COMPARISON_BENCH
import qualified Data.Binary as Binary
import qualified Data.Serialize as Cereal
import qualified Data.ByteString.Lazy as BL
import           Data.Vector.Serialize ()
#endif

data SomeData = SomeData !Int64 !Word8 !Double
    deriving (Eq, Show, Generic, Typeable)
instance NFData SomeData where
    rnf x = x `seq` ()
instance Store SomeData
#if COMPARISON_BENCH
instance Cereal.Serialize SomeData
instance Binary.Binary SomeData
#endif

main :: IO ()
main = do
#if SMALL_BENCH
    let is = 0::Int
        sds = SomeData 1 1 1
        smallprods = (SmallProduct 0 1 2 3)
        smallmanualprods = (SmallProductManual 0 1 2 3)
        sss = [SS1 1, SS2 2, SS3 3, SS4 4]
        ssms = [SSM1 1, SSM2 2, SSM3 3, SSM4 4]
        nestedTuples = ((1,2),(3,4)) :: ((Int,Int),(Int,Int))
#else
    let is = V.enumFromTo 1 100 :: V.Vector Int
        sds = (\i -> SomeData i (fromIntegral i) (fromIntegral i))
            <$> V.enumFromTo 1 100
        smallprods = (\ i -> SmallProduct i (i+1) (i+2) (i+3))
            <$> V.enumFromTo 1 100
        smallmanualprods = (\ i -> SmallProductManual i (i+1) (i+2) (i+3))
            <$> V.enumFromTo 1 100
        sss = (\i -> case i `mod` 4 of
                      0 -> SS1 (fromIntegral i)
                      1 -> SS2 (fromIntegral i)
                      2 -> SS3 (fromIntegral i)
                      3 -> SS4 (fromIntegral i)
                      _ -> error "This does not compute."
              ) <$> V.enumFromTo 1 (100 :: Int)
        ssms = (\i -> case i `mod` 4 of
                       0 -> SSM1 (fromIntegral i)
                       1 -> SSM2 (fromIntegral i)
                       2 -> SSM3 (fromIntegral i)
                       3 -> SSM4 (fromIntegral i)
                       _ -> error "This does not compute."
               ) <$> V.enumFromTo 1 (100 :: Int)
        nestedTuples = (\i -> ((i,i+1),(i+2,i+3))) <$> V.enumFromTo (1::Int) 100

        ints = [1..100] :: [Int]
        pairs = map (\x -> (x, x)) ints
        strings = show <$> ints
        intsSet = Set.fromDistinctAscList ints
        intSet = IntSet.fromDistinctAscList ints
        intsMap = Map.fromDistinctAscList pairs
        intMap = IntMap.fromDistinctAscList pairs
        stringsSet = Set.fromList strings
        stringsMap = Map.fromList (zip strings ints)
#endif
    defaultMain
        [ bgroup "encode"
            [ benchEncode is
#if !SMALL_BENCH
            , benchEncode' "1kb storable" (SV.fromList ([1..256] :: [Int32]))
            , benchEncode' "10kb storable" (SV.fromList ([1..(256 * 10)] :: [Int32]))
            , benchEncode' "1kb normal" (V.fromList ([1..256] :: [Int32]))
            , benchEncode' "10kb normal" (V.fromList ([1..(256 * 10)] :: [Int32]))
            , benchEncode intsSet
            , benchEncode intSet
            , benchEncode intsMap
            , benchEncode intMap
            , benchEncode stringsSet
            , benchEncode stringsMap
#endif
            , benchEncode smallprods
            , benchEncode smallmanualprods
            , benchEncode sss
            , benchEncode ssms
            , benchEncode nestedTuples
            , benchEncode sds
            ]
        , bgroup "decode"
            [ benchDecode is
#if !SMALL_BENCH
            , benchDecode' "1kb storable" (SV.fromList ([1..256] :: [Int32]))
            , benchDecode' "10kb storable" (SV.fromList ([1..(256 * 10)] :: [Int32]))
            , benchDecode' "1kb normal" (V.fromList ([1..256] :: [Int32]))
            , benchDecode' "10kb normal" (V.fromList ([1..(256 * 10)] :: [Int32]))
            , benchDecode intsSet
            , benchDecode intSet
            , benchDecode intsMap
            , benchDecode intMap
            , benchDecode stringsSet
            , benchDecode stringsMap
#endif
            , benchDecode smallprods
            , benchDecode smallmanualprods
            , benchDecode sss
            , benchDecode ssms
            , benchDecode nestedTuples
            , benchDecode sds
            ]
        ]

type Ctx a =
    ( Store a, Typeable a, NFData a
#if COMPARISON_BENCH
    , Binary.Binary a
    , Cereal.Serialize a
#endif
    )

benchEncode :: Ctx a => a -> Benchmark
benchEncode = benchEncode' ""

benchEncode' :: Ctx a => String -> a -> Benchmark
benchEncode' msg x0 =
    env (return x0) $ \x ->
        let label = msg ++ " (" ++ show (typeOf x0) ++ ")"
            benchStore name = bench name (nf encode x) in
#if COMPARISON_BENCH
        bgroup label
            [ benchStore "store"
            , bench "cereal" (nf Cereal.encode x)
            , bench "binary" (nf Binary.encode x)
            ]
#else
        benchStore label
#endif

benchDecode :: Ctx a => a -> Benchmark
benchDecode = benchDecode' ""

benchDecode' :: forall a. Ctx a => String -> a -> Benchmark
#if COMPARISON_BENCH
benchDecode' prefix x0 =
    bgroup label
        [ env (return (encode x0)) $ \x -> bench "store" (nf (decodeEx :: BS.ByteString -> a) x)
        , env (return (Cereal.encode x0)) $ \x -> bench "cereal" (nf ((ensureRight . Cereal.decode) :: BS.ByteString -> a) x)
        , env (return (Binary.encode x0)) $ \x -> bench "binary" (nf (Binary.decode :: BL.ByteString -> a) x)
        ]
  where
    label = prefix ++ " (" ++ show (typeOf x0) ++ ")"
    ensureRight (Left x) = error "left!"
    ensureRight (Right x) = x
#else
benchDecode' prefix x0 =
    env (return (encode x0)) $ \x ->
        bench (prefix ++ " (" ++ show (typeOf x0) ++ ")") (nf (decodeEx :: BS.ByteString -> a) x)
#endif

------------------------------------------------------------------------
-- Serialized datatypes

data SmallProduct = SmallProduct Int32 Int32 Int32 Int32
    deriving (Generic, Show, Typeable)

instance NFData SmallProduct
instance Store SmallProduct

data SmallProductManual = SmallProductManual Int32 Int32 Int32 Int32
    deriving (Generic, Show, Typeable)

instance NFData SmallProductManual
instance Store SmallProductManual where
    size = ConstSize 16
    peek = SmallProductManual <$> peek <*> peek <*> peek <*> peek
    poke (SmallProductManual a b c d) = poke a *> poke b *> poke c *> poke d

data SmallSum
    = SS1 Int8
    | SS2 Int32
    | SS3 Int64
    | SS4 Word32
    deriving (Generic, Show, Typeable)

instance NFData SmallSum
instance Store SmallSum

data SmallSumManual
    = SSM1 Int8
    | SSM2 Int32
    | SSM3 Int64
    | SSM4 Word32
    deriving (Generic, Show, Typeable)

instance NFData SmallSumManual
instance Store SmallSumManual where
    size = VarSize $ \x -> 1 + case x of
        SSM1{} -> 1
        SSM2{} -> 4
        SSM3{} -> 8
        SSM4{} -> 4
    peek = do
        tag <- peek
        case tag :: Word8 of
            0 -> SSM1 <$> peek
            1 -> SSM2 <$> peek
            2 -> SSM3 <$> peek
            3 -> SSM4 <$> peek
            _ -> fail "Invalid tag"
    poke (SSM1 x) = poke (0 :: Word8) >> poke x
    poke (SSM2 x) = poke (1 :: Word8) >> poke x
    poke (SSM3 x) = poke (2 :: Word8) >> poke x
    poke (SSM4 x) = poke (3 :: Word8) >> poke x

#if COMPARISON_BENCH
instance Binary.Binary SmallProduct
instance Binary.Binary SmallSum
instance Cereal.Serialize SmallProduct
instance Cereal.Serialize SmallSum

instance Binary.Binary SmallProductManual where
    get = SmallProductManual <$> Binary.get <*> Binary.get <*> Binary.get <*> Binary.get
    put (SmallProductManual a b c d) = Binary.put a *> Binary.put b *> Binary.put c *> Binary.put d

instance Binary.Binary SmallSumManual where
    get = do
        tag <- Binary.get
        case tag :: Word8 of
            0 -> SSM1 <$> Binary.get
            1 -> SSM2 <$> Binary.get
            2 -> SSM3 <$> Binary.get
            3 -> SSM4 <$> Binary.get
            _ -> fail "Invalid tag"
    put (SSM1 x) = Binary.put (0 :: Word8) *> Binary.put x
    put (SSM2 x) = Binary.put (1 :: Word8) *> Binary.put x
    put (SSM3 x) = Binary.put (2 :: Word8) *> Binary.put x
    put (SSM4 x) = Binary.put (3 :: Word8) *> Binary.put x

instance Cereal.Serialize SmallProductManual where
    get = SmallProductManual <$> Cereal.get <*> Cereal.get <*> Cereal.get <*> Cereal.get
    put (SmallProductManual a b c d) = Cereal.put a *> Cereal.put b *> Cereal.put c *> Cereal.put d

instance Cereal.Serialize SmallSumManual where
    get = do
        tag <- Cereal.get
        case tag :: Word8 of
            0 -> SSM1 <$> Cereal.get
            1 -> SSM2 <$> Cereal.get
            2 -> SSM3 <$> Cereal.get
            3 -> SSM4 <$> Cereal.get
            _ -> fail "Invalid tag"
    put (SSM1 x) = Cereal.put (0 :: Word8) *> Cereal.put x
    put (SSM2 x) = Cereal.put (1 :: Word8) *> Cereal.put x
    put (SSM3 x) = Cereal.put (2 :: Word8) *> Cereal.put x
    put (SSM4 x) = Cereal.put (3 :: Word8) *> Cereal.put x
#endif
