{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Test.MessagePack.Generate (generate) where

import           Control.Monad                    (when)
import qualified Data.ByteString.Lazy             as L
import           Data.Int                         (Int64)
import           Data.MessagePack.Arbitrary       ()
import           Data.MessagePack.Types           (Object (..))
import           Data.Time.Clock                  (diffUTCTime, getCurrentTime)
import           System.Environment               (getArgs)
import           System.IO                        (hPutStr, hPutStrLn, stderr)
import           Test.QuickCheck.Arbitrary        (arbitrary)
import qualified Test.QuickCheck.Gen              as Gen
import           Test.QuickCheck.Instances.Vector ()
import           Test.QuickCheck.Random           (mkQCGen)


seed :: Int
seed :: Int
seed = Int
33


showBytes :: Int64 -> String
showBytes :: Int64 -> String
showBytes Int64
size
  | Int64
size Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
10 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* (Int64
1024 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1024) = Int64 -> String
forall a. Show a => a -> String
show (Int64
size Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` (Int64
1024 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1024)) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" MiB"
  | Int64
size Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
10 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1024 = Int64 -> String
forall a. Show a => a -> String
show (Int64
size Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1024) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" KiB"
  | Bool
otherwise = Int64 -> String
forall a. Show a => a -> String
show Int64
size String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" B"


showSpeed :: Int64 -> Double -> String
showSpeed :: Int64 -> Double -> String
showSpeed Int64
size Double
time =
    Double -> String
forall a. Show a => a -> String
show (Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
size Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1024 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1024) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
time) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" MiB/s"


generate :: (Object -> L.ByteString) -> IO ()
generate :: (Object -> ByteString) -> IO ()
generate Object -> ByteString
pack = do
    Int
size:[Int]
_ <- ([Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++[Int
30]) ([Int] -> [Int]) -> ([String] -> [Int]) -> [String] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. Read a => String -> a
read ([String] -> [Int]) -> IO [String] -> IO [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
getArgs

    UTCTime
start <- IO UTCTime
getCurrentTime
    Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Generating sample..."

    let sample :: Object
sample@(ObjectArray Vector Object
array) = Vector Object -> Object
ObjectArray (Vector Object -> Object) -> Vector Object -> Object
forall a b. (a -> b) -> a -> b
$ Gen (Vector Object) -> QCGen -> Int -> Vector Object
forall a. Gen a -> QCGen -> Int -> a
Gen.unGen (Int -> Gen (Vector Object) -> Gen (Vector Object)
forall a. HasCallStack => Int -> Gen a -> Gen a
Gen.resize Int
size Gen (Vector Object)
forall a. Arbitrary a => Gen a
arbitrary) (Int -> QCGen
mkQCGen Int
0) Int
seed
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Object
sample Object -> Object -> Bool
forall a. Eq a => a -> a -> Bool
== Object
sample) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$  -- force deep evaluation of the whole structure (kind of deepseq)
        Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Generated msgpack array of length " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Vector Object -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector Object
array)
    UTCTime
sampleTime <- IO UTCTime
getCurrentTime
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
sampleTime UTCTime
start)

    let packed :: ByteString
packed = Object -> ByteString
pack Object
sample
    Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Message packed into " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
showBytes (ByteString -> Int64
L.length ByteString
packed)
    UTCTime
packTime <- IO UTCTime
getCurrentTime
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
packTime UTCTime
sampleTime)

    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Packing speed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> Double -> String
showSpeed (ByteString -> Int64
L.length ByteString
packed) (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
packTime UTCTime
sampleTime))

    ByteString -> IO ()
L.putStr ByteString
packed