{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}

module Main (main) where

import Criterion

import Criterion.Main

import Data.Monoid ((<>))

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL

import qualified Data.BufferBuilder.Json as Json
import           Data.Text (Text)
import qualified Data.Aeson as Aeson
import           Data.Aeson ((.:))
import qualified Data.Vector as Vector
import           Control.DeepSeq (NFData (..), force)
import qualified Data.Vector.Unboxed as UnboxedVector

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
instance NFData Gender
instance NFData Fruit

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"

instance Aeson.ToJSON Gender where
    toJSON g = Aeson.toJSON $ 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"

instance Aeson.ToJSON Friend where
    toJSON Friend {..} = Aeson.object
        [ "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
        ]

--- 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

encodeUserNaively :: User -> Json.Value
encodeUserNaively 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
--- ---

main :: IO ()
main = do
    content <- BS.readFile "test.json"
    let lazyContent = force $ BSL.fromChunks [content]

    let parsedUserList :: [User]
        Just parsedUserList = Aeson.decode lazyContent

    defaultMain [ bgroup "vector"
                    [ bench "vector bool" $ nf Json.encodeJson (Vector.replicate 100000 True)
                    , bench "vector int" $ nf Json.encodeJson (Vector.replicate 100000 (1234 :: Int))
                    , bench "vector text" $ nf Json.encodeJson (Vector.replicate 100000 ("hello world" :: Text))
                    ]
                , bgroup "list-foldable"
                    [ bench "list-foldable bool" $ nf (Json.encodeJson . Json.array) (replicate 100000 True)
                    , bench "list-foldable int" $ nf (Json.encodeJson . Json.array) (replicate 100000 (1234 :: Int))
                    , bench "list-foldable text" $ nf (Json.encodeJson . Json.array) (replicate 100000 ("hello world" :: Text))
                    ]
                , bgroup "list"
                    [ bench "list bool" $ nf Json.encodeJson (replicate 100000 True)
                    , bench "list int" $ nf Json.encodeJson (replicate 100000 (1234 :: Int))
                    , bench "list text" $ nf Json.encodeJson (replicate 100000 ("hello world" :: Text))
                    ]
                , bgroup "render"
                    [ bench "bufferbuilder" $ nf Json.encodeJson parsedUserList
                    , bench "aeson" $ nf Aeson.encode parsedUserList
                    ]
                , bgroup "addr vs text keys"
                    [ bench "addr" $ nf Json.encodeJson parsedUserList
                    , bench "text" $ nf Json.encodeJson $ fmap encodeUserNaively parsedUserList
                    ]
                , bgroup "breakout"
                    [ bench "Vector" $ nf Json.encodeJson (Vector.fromList $! [0..65535] :: Vector.Vector Int)
                    , bench "Vector.Unboxed" $ nf Json.encodeJson (UnboxedVector.fromList $! [0..65535] :: UnboxedVector.Vector Int)
                    ]
                ]