diff --git a/bench/Data/MessagePackBench.hs b/bench/Data/MessagePackBench.hs --- a/bench/Data/MessagePackBench.hs +++ b/bench/Data/MessagePackBench.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} module Data.MessagePackBench (suite) where import Control.DeepSeq (NFData) @@ -8,13 +10,33 @@ import Test.QuickCheck.Gen (resize, unGen) import Test.QuickCheck.Random (mkQCGen) +import GHC.Generics + import Data.MessagePack defaultSeed :: Int defaultSeed = 301 +instance MessagePack a => MessagePack (Maybe a) +data Expr + = I Int + | Add Expr Expr + | Prod Expr Expr + deriving (NFData, Generic) + +instance MessagePack Expr + +expr :: Int -> Expr +expr i = foldr build (I 10) [0..i] where + build x e = + case x `mod` 4 of + 0 -> Add e e + 1 -> Prod e e + 2 -> Add e (I x) + 3 -> Prod (I x) e + arb :: Arbitrary a => Int -> a arb size = let g = unGen $ resize size arbitrary in @@ -34,14 +56,16 @@ suite :: [Benchmark] suite = [ bgroup "pack" - [ bench "Just Int" $ nf pack (Just (3 :: Int)) + [ bgroup "Expr" $ benchRange 10 40 4 pack expr + , bench "Just Int" $ nf pack (Just (3 :: Int)) , bench "Nothing" $ nf pack (Nothing :: Maybe Int) , bench "()" $ nf pack () , bgroup "[a]" $ benchRange 1000 10000 10 pack (`replicate` ()) -- ^ should be linear ] , bgroup "unpack" - [ bench "Just Int" $ nf (unpack :: LBS.ByteString -> Maybe Int) (pack (Just (3 :: Int))) + [ bgroup "Expr" $ benchRange 10 100 10 (unpack :: LBS.ByteString -> Maybe Expr) (pack . expr) + , bench "Just Int" $ nf (unpack :: LBS.ByteString -> Maybe Int) (pack (Just (3 :: Int))) , bench "Nothing" $ nf (unpack :: LBS.ByteString -> Maybe Int) (pack (Nothing :: Maybe Int)) , bench "()" $ nf (unpack :: LBS.ByteString -> Maybe () ) (pack ()) , bgroup "[a]" $ benchRange 1000 10000 10 pack (`replicate` ()) diff --git a/msgpack-binary.cabal b/msgpack-binary.cabal --- a/msgpack-binary.cabal +++ b/msgpack-binary.cabal @@ -1,5 +1,5 @@ name: msgpack-binary -version: 0.0.15 +version: 0.0.16 synopsis: A Haskell implementation of MessagePack homepage: http://msgpack.org/ license: BSD3 @@ -40,9 +40,28 @@ , bytestring , data-binary-ieee754 , monad-validate - , msgpack-types >= 0.2 && < 0.3 + , msgpack-types >= 0.3 && < 0.4 , text + , vector +executable msgpack-gen-sample + default-language: Haskell2010 + hs-source-dirs: + tools + ghc-options: + -Wall + -fno-warn-unused-imports + main-is: msgpack-gen-sample.hs + build-depends: + base < 5 + , QuickCheck + , bytestring + , msgpack-arbitrary + , msgpack-binary + , quickcheck-instances + , time + , vector + executable msgpack-parser default-language: Haskell2010 hs-source-dirs: @@ -64,22 +83,14 @@ main-is: testsuite.hs other-modules: Data.MessagePackSpec - Data.Result ghc-options: -Wall -fno-warn-unused-imports build-depends: base < 5 - , QuickCheck - , bytestring - , containers - , hashable , hspec , msgpack-binary - , msgpack-types - , text - , unordered-containers - , vector + , msgpack-testsuite >= 0.0.16 && < 0.1 benchmark benchmark type: exitcode-stdio-1.0 diff --git a/src/Data/MessagePack.hs b/src/Data/MessagePack.hs --- a/src/Data/MessagePack.hs +++ b/src/Data/MessagePack.hs @@ -18,20 +18,21 @@ -------------------------------------------------------------------- module Data.MessagePack ( - -- * Simple interface to pack and unpack msgpack binary - pack - , unpack - , unpackEither - , unpackValidate + -- * Simple interface to pack and unpack msgpack binary + pack + , unpack + , unpackEither + , unpackValidate - -- * Re-export modules - -- $reexports - , module X - ) where + -- * Re-export modules + -- $reexports + , module X + ) where import Control.Applicative (Applicative) import Control.Monad ((>=>)) -import Control.Monad.Validate (MonadValidate (..), runValidate) +import Control.Monad.Validate (MonadValidate (..), Validate, + runValidate) import Data.Binary (Binary (..), decodeOrFail, encode) import Data.Binary.Get (Get) import qualified Data.ByteString.Lazy as L @@ -48,8 +49,8 @@ -- | Unpack MessagePack binary to a Haskell value. -- -- On failure, returns a list of error messages. -unpackValidate :: (MonadValidate DecodeError m, MessagePack a) - => L.ByteString -> m a +unpackValidate :: MessagePack a + => L.ByteString -> Validate DecodeError a unpackValidate = eitherToM . decodeOrFail >=> fromObjectWith defaultConfig where eitherToM (Left (_, _, msg)) = refute $ decodeError msg @@ -76,11 +77,12 @@ instance Binary Object where - get = getObject - {-# INLINE get #-} + get = getObject + {-# INLINE get #-} - put = putObject - {-# INLINE put #-} + put = putObject + {-# INLINE put #-} + instance MonadValidate DecodeError Get where refute = fail . show diff --git a/src/Data/MessagePack/Get.hs b/src/Data/MessagePack/Get.hs --- a/src/Data/MessagePack/Get.hs +++ b/src/Data/MessagePack/Get.hs @@ -41,6 +41,7 @@ import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Vector as V import Data.Word (Word64, Word8) import Data.MessagePack.Types (Object (..)) @@ -118,7 +119,7 @@ _ -> empty getByteString len -getArray :: Get a -> Get [a] +getArray :: Get a -> Get (V.Vector a) getArray g = do len <- getWord8 >>= \case t | t .&. 0xF0 == 0x90 -> @@ -126,9 +127,9 @@ 0xDC -> fromIntegral <$> getWord16be 0xDD -> fromIntegral <$> getWord32be _ -> empty - replicateM len g + V.replicateM len g -getMap :: Get a -> Get b -> Get [(a, b)] +getMap :: Get a -> Get b -> Get (V.Vector (a, b)) getMap k v = do len <- getWord8 >>= \case t | t .&. 0xF0 == 0x80 -> @@ -136,7 +137,7 @@ 0xDE -> fromIntegral <$> getWord16be 0xDF -> fromIntegral <$> getWord32be _ -> empty - replicateM len $ (,) <$> k <*> v + V.replicateM len $ (,) <$> k <*> v getExt :: Get (Word8, S.ByteString) getExt = do diff --git a/src/Data/MessagePack/Put.hs b/src/Data/MessagePack/Put.hs --- a/src/Data/MessagePack/Put.hs +++ b/src/Data/MessagePack/Put.hs @@ -39,6 +39,7 @@ import Data.Int (Int64) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Vector as V import Data.Word (Word64, Word8) import Prelude hiding (putStr) @@ -70,36 +71,36 @@ putInt :: Int64 -> Put putInt n | -0x20 <= n && n < 0x80 = - putWord8 (fromIntegral n) + putWord8 (fromIntegral n) | 0 <= n && n < 0x100 = - putWord8 0xCC >> putWord8 (fromIntegral n) + putWord8 0xCC >> putWord8 (fromIntegral n) | 0 <= n && n < 0x10000 = - putWord8 0xCD >> putWord16be (fromIntegral n) + putWord8 0xCD >> putWord16be (fromIntegral n) | 0 <= n && n < 0x100000000 = - putWord8 0xCE >> putWord32be (fromIntegral n) + putWord8 0xCE >> putWord32be (fromIntegral n) | 0 <= n = - putWord8 0xCF >> putWord64be (fromIntegral n) + putWord8 0xCF >> putWord64be (fromIntegral n) | -0x80 <= n = - putWord8 0xD0 >> putWord8 (fromIntegral n) + putWord8 0xD0 >> putWord8 (fromIntegral n) | -0x8000 <= n = - putWord8 0xD1 >> putWord16be (fromIntegral n) + putWord8 0xD1 >> putWord16be (fromIntegral n) | -0x80000000 <= n = - putWord8 0xD2 >> putWord32be (fromIntegral n) + putWord8 0xD2 >> putWord32be (fromIntegral n) | otherwise = putWord8 0xD3 >> putWord64be (fromIntegral n) putWord :: Word64 -> Put putWord n | n < 0x80 = - putWord8 (fromIntegral n) + putWord8 (fromIntegral n) | n < 0x100 = - putWord8 0xCC >> putWord8 (fromIntegral n) + putWord8 0xCC >> putWord8 (fromIntegral n) | n < 0x10000 = - putWord8 0xCD >> putWord16be (fromIntegral n) + putWord8 0xCD >> putWord16be (fromIntegral n) | n < 0x100000000 = - putWord8 0xCE >> putWord32be (fromIntegral n) + putWord8 0xCE >> putWord32be (fromIntegral n) | otherwise = - putWord8 0xCF >> putWord64be n + putWord8 0xCF >> putWord64be n putFloat :: Float -> Put putFloat f = do @@ -136,27 +137,27 @@ putWord8 0xC6 >> putWord32be (fromIntegral len) putByteString bs -putArray :: (a -> Put) -> [a] -> Put +putArray :: (a -> Put) -> V.Vector a -> Put putArray p xs = do - case length xs of + case V.length xs of len | len <= 15 -> putWord8 $ 0x90 .|. fromIntegral len | len < 0x10000 -> putWord8 0xDC >> putWord16be (fromIntegral len) | otherwise -> putWord8 0xDD >> putWord32be (fromIntegral len) - mapM_ p xs + V.mapM_ p xs -putMap :: (a -> Put) -> (b -> Put) -> [(a, b)] -> Put +putMap :: (a -> Put) -> (b -> Put) -> V.Vector (a, b) -> Put putMap p q xs = do - case length xs of + case V.length xs of len | len <= 15 -> putWord8 $ 0x80 .|. fromIntegral len | len < 0x10000 -> putWord8 0xDE >> putWord16be (fromIntegral len) | otherwise -> putWord8 0xDF >> putWord32be (fromIntegral len) - mapM_ (\(a, b) -> p a >> q b) xs + V.mapM_ (\(a, b) -> p a >> q b) xs putExt :: Word8 -> S.ByteString -> Put putExt typ dat = do diff --git a/test/Data/MessagePackSpec.hs b/test/Data/MessagePackSpec.hs --- a/test/Data/MessagePackSpec.hs +++ b/test/Data/MessagePackSpec.hs @@ -1,349 +1,21 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE Trustworthy #-} module Data.MessagePackSpec where import Test.Hspec -import Test.QuickCheck -import qualified Test.QuickCheck.Gen as Gen -import Control.Applicative ((<$>), (<*>)) -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy as L8 -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.HashMap.Strict as HashMap -import Data.Hashable (Hashable) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Result as R -import qualified Data.Text.Lazy as LT -import qualified Data.Vector as V -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Unboxed as VU -import Data.Word (Word, Word16, Word32, Word64, - Word8) -import GHC.Generics (Generic) - -import Data.MessagePack - - -data Unit = Unit - deriving (Eq, Show, Generic) - -instance MessagePack Unit - - -data TyConArgs = TyConArgs Int Int Int - deriving (Eq, Show, Generic) - -instance MessagePack TyConArgs - - -data Record = Record - { recordField1 :: Int - , recordField2 :: Double - , recordField3 :: String - } - deriving (Eq, Show, Generic) - -instance MessagePack Record - - -data Foo - = Foo1 - | Foo2 Int - | Foo3 Int - | Foo4 Int - | Foo5 Int - | Foo6 { unFoo3 :: Int } - | Foo7 Int - | Foo8 Int Int - | Foo9 Int Int Int - deriving (Eq, Show, Generic) - -instance MessagePack Foo - -instance Arbitrary Foo where - arbitrary = Gen.oneof - [ return Foo1 - , Foo2 <$> arbitrary - , Foo3 <$> arbitrary - , Foo4 <$> arbitrary - , Foo5 <$> arbitrary - , Foo6 <$> arbitrary - , Foo7 <$> arbitrary - , Foo8 <$> arbitrary <*> arbitrary - , Foo9 <$> arbitrary <*> arbitrary <*> arbitrary - ] - - -instance (Hashable k, Ord k, Eq k, Arbitrary k, Arbitrary v) - => Arbitrary (HashMap.HashMap k v) where - arbitrary = HashMap.fromList . Map.assocs <$> arbitrary - -instance Arbitrary a => Arbitrary (V.Vector a) where - arbitrary = V.fromList <$> arbitrary - -instance (Arbitrary a, VS.Storable a) => Arbitrary (VS.Vector a) where - arbitrary = VS.fromList <$> arbitrary - -instance (Arbitrary a, VU.Unbox a) => Arbitrary (VU.Vector a) where - arbitrary = VU.fromList <$> arbitrary - -instance Arbitrary S.ByteString where - arbitrary = S.pack <$> arbitrary - -instance Arbitrary L.ByteString where - arbitrary = L.pack <$> arbitrary - -instance Arbitrary LT.Text where - arbitrary = LT.pack <$> arbitrary - -mid :: MessagePack a => a -> a -mid = Maybe.fromJust . unpack . pack - - -intMid :: Int64 -> Int64 -intMid = mid +import qualified Data.MessagePack as Impl +import Test.MessagePack.BytePacker (BytePacker) +import qualified Test.MessagePack.BytePacker as BytePacker +import qualified Test.MessagePack.Spec as MessagePackSpec -coerce :: (MessagePack a, MessagePack b) => a -> Maybe b -coerce = unpack . pack - +data Packer = Packer -checkMessage :: Show a => R.Result a -> Expectation -checkMessage (R.Success res) = - expectationFailure $ "unexpected success: " ++ show res -checkMessage (R.Failure msg) = - msg `shouldContain` "invalid encoding for " +instance BytePacker Packer where + pack Packer = Impl.pack + unpackValidate Packer = Impl.unpackValidate spec :: Spec -spec = do - describe "unpack" $ - it "does not throw exceptions on arbitrary data" $ - property $ \bs -> - case unpack bs of - Just "" -> return () :: IO () - _ -> return () :: IO () - - describe "Assoc" $ do - it "supports read/show" $ - property $ \(a :: Assoc [(Int, Int)]) -> - read (show a) `shouldBe` a - - it "inherits ordering from its contained type" $ - property $ \(a :: Assoc Int) b -> - (unAssoc a < unAssoc b) `shouldBe` (a < b) - - describe "failures" $ - it "should contain the same start of the failure message for all types" $ do - checkMessage (unpack (pack $ ObjectInt (-1)) :: R.Result Foo) - checkMessage (unpack (pack [ObjectInt (-1), ObjectInt 0]) :: R.Result Foo) - checkMessage (unpack (pack $ ObjectArray []) :: R.Result TyConArgs) - checkMessage (unpack (pack $ ObjectArray []) :: R.Result Record) - checkMessage (unpack (pack [0 :: Int, 1, 2, 3]) :: R.Result Record) - checkMessage (unpack (pack "") :: R.Result Unit) - checkMessage (unpack (pack "") :: R.Result TyConArgs) - checkMessage (unpack (pack "") :: R.Result Record) - checkMessage (unpack (pack "") :: R.Result ()) - checkMessage (unpack (pack ()) :: R.Result Int) - checkMessage (unpack (pack ()) :: R.Result Bool) - checkMessage (unpack (pack ()) :: R.Result Float) - checkMessage (unpack (pack ()) :: R.Result Double) - checkMessage (unpack (pack ()) :: R.Result S.ByteString) - checkMessage (unpack (pack ()) :: R.Result LT.Text) - checkMessage (unpack (pack "") :: R.Result [String]) - checkMessage (unpack (pack ()) :: R.Result (V.Vector Int)) - checkMessage (unpack (pack ()) :: R.Result (VS.Vector Int)) - checkMessage (unpack (pack ()) :: R.Result (VU.Vector Int)) - checkMessage (unpack (pack "") :: R.Result (Assoc [(Int, Int)])) - checkMessage (unpack (pack ()) :: R.Result (Int, Int)) - checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int)) - checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int)) - checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int)) - checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int)) - checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int)) - checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int, Int)) - checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int, Int, Int)) - - describe "type coercion" $ do - it "bool<-int" $ - property $ \(a :: Int) -> coerce a `shouldBe` (Nothing :: Maybe Bool) - - it "int<-bool" $ - property $ \(a :: Bool) -> coerce a `shouldBe` (Nothing :: Maybe Int) - - it "float<-int" $ - property $ \(a :: Int) -> coerce a `shouldBe` Just (fromIntegral a :: Float) - it "float<-double" $ - property $ \(a :: Double) -> coerce a `shouldBe` Just (realToFrac a :: Float) - it "float<-string" $ - property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe Float) - - it "double<-int" $ - property $ \(a :: Int) -> coerce a `shouldBe` Just (fromIntegral a :: Double) - it "double<-float" $ - property $ \(a :: Float) -> coerce a `shouldBe` Just (realToFrac a :: Double) - it "double<-string" $ - property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe Double) - - it "bin<-string" $ - property $ \(a :: S.ByteString) -> coerce a `shouldBe` (Nothing :: Maybe String) - - it "string<-bin" $ - property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe S.ByteString) - - describe "Identity Properties" $ do - let sizes = [0xf, 0x10, 0x1f, 0x20, 0xff, 0x100, 0xffff, 0x10000] - - it "unit encoding" $ - Unit `shouldBe` mid Unit - - it "map encodings" $ do - let rt n = let a = IntMap.fromList [(x, -x) | x <- [0..n]] in a `shouldBe` mid a - mapM_ rt sizes - - it "list encodings" $ do - let rt n = let a = replicate n "hello" in a `shouldBe` mid a - mapM_ rt sizes - - it "vector encodings" $ do - let rt n = let a = V.fromList [0..n] in a `shouldBe` mid a - mapM_ rt sizes - - it "storable-vector encodings" $ do - let rt n = let a = VS.fromList [0..n] in a `shouldBe` mid a - mapM_ rt sizes - - it "unboxed-vector encodings" $ do - let rt n = let a = VU.fromList [0..n] in a `shouldBe` mid a - mapM_ rt sizes - - it "string encodings" $ do - let rt n = let a = replicate n 'a' in a `shouldBe` mid a - mapM_ rt sizes - - it "bytestring encodings" $ do - let rt n = let a = S.pack $ replicate n 'a' in a `shouldBe` mid a - mapM_ rt sizes - - it "ext encodings" $ do - let rt n = let a = ObjectExt 0 $ S.pack $ replicate n 'a' in a `shouldBe` mid a - mapM_ rt [0..20] - mapM_ rt sizes - - it "int encodings" $ do - (-0x7fffffffffffffff) `shouldBe` intMid (-0x7fffffffffffffff) - (-0x80000000) `shouldBe` intMid (-0x80000000) - (-0x7fffffff) `shouldBe` intMid (-0x7fffffff) - (-0x8000) `shouldBe` intMid (-0x8000) - (-0x7fff) `shouldBe` intMid (-0x7fff) - (-1) `shouldBe` intMid (-1) - 0 `shouldBe` intMid 0 - 1 `shouldBe` intMid 1 - 0x7fff `shouldBe` intMid 0x7fff - 0x8000 `shouldBe` intMid 0x8000 - 0x7fffffff `shouldBe` intMid 0x7fffffff - 0x80000000 `shouldBe` intMid 0x80000000 - 0x7fffffffffffffff `shouldBe` intMid 0x7fffffffffffffff - - it "int" $ property $ \(a :: Int ) -> a `shouldBe` mid a - it "int8" $ property $ \(a :: Int8 ) -> a `shouldBe` mid a - it "int16" $ property $ \(a :: Int16 ) -> a `shouldBe` mid a - it "int32" $ property $ \(a :: Int32 ) -> a `shouldBe` mid a - it "int64" $ property $ \(a :: Int64 ) -> a `shouldBe` mid a - it "word" $ property $ \(a :: Word ) -> a `shouldBe` mid a - it "word8" $ property $ \(a :: Word8 ) -> a `shouldBe` mid a - it "word16" $ property $ \(a :: Word16) -> a `shouldBe` mid a - it "word32" $ property $ \(a :: Word32) -> a `shouldBe` mid a - it "word64" $ property $ \(a :: Word64) -> a `shouldBe` mid a - - it "ext" $ - property $ \(n, a) -> ObjectExt n a `shouldBe` mid (ObjectExt n a) - it "nil" $ - property $ \(a :: ()) -> a `shouldBe` mid a - it "bool" $ - property $ \(a :: Bool) -> a `shouldBe` mid a - it "float" $ - property $ \(a :: Float) -> a `shouldBe` mid a - it "double" $ - property $ \(a :: Double) -> a `shouldBe` mid a - it "string" $ - property $ \(a :: String) -> a `shouldBe` mid a - it "bytestring" $ - property $ \(a :: S.ByteString) -> a `shouldBe` mid a - it "lazy-bytestring" $ - property $ \(a :: L.ByteString) -> a `shouldBe` mid a - it "lazy-text" $ - property $ \(a :: LT.Text) -> a `shouldBe` mid a - it "[int]" $ - property $ \(a :: [Int]) -> a `shouldBe` mid a - it "vector int" $ - property $ \(a :: V.Vector Int) -> a `shouldBe` mid a - it "storable-vector int" $ - property $ \(a :: VS.Vector Int) -> a `shouldBe` mid a - it "unboxed-vector int" $ - property $ \(a :: VU.Vector Int) -> a `shouldBe` mid a - it "[string]" $ - property $ \(a :: [String]) -> a `shouldBe` mid a - it "(int, int)" $ - property $ \(a :: (Int, Int)) -> a `shouldBe` mid a - it "(int, int, int)" $ - property $ \(a :: (Int, Int, Int)) -> a `shouldBe` mid a - it "(int, int, int, int)" $ - property $ \(a :: (Int, Int, Int, Int)) -> a `shouldBe` mid a - it "(int, int, int, int, int)" $ - property $ \(a :: (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a - it "(int, int, int, int, int, int)" $ - property $ \(a :: (Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a - it "(int, int, int, int, int, int, int)" $ - property $ \(a :: (Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a - it "(int, int, int, int, int, int, int, int)" $ - property $ \(a :: (Int, Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a - it "(int, int, int, int, int, int, int, int, int)" $ - property $ \(a :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a - it "[(int, double)]" $ - property $ \(a :: [(Int, Double)]) -> a `shouldBe` mid a - it "[(string, string)]" $ - property $ \(a :: [(String, String)]) -> a `shouldBe` mid a - it "Assoc [(string, int)]" $ - property $ \(a :: Assoc [(String, Int)]) -> a `shouldBe` mid a - it "Map String Int" $ - property $ \(a :: Map.Map String Int) -> a `shouldBe` mid a - it "IntMap Int" $ - property $ \(a :: IntMap.IntMap Int) -> a `shouldBe` mid a - it "HashMap String Int" $ - property $ \(a :: HashMap.HashMap String Int) -> a `shouldBe` mid a - - it "generics" $ - property $ \(a :: Foo) -> a `shouldBe` mid a - it "arbitrary message" $ - property $ \(a :: Object) -> a `shouldBe` mid a - - describe "encoding validation" $ do - it "word64 2^64-1" $ - pack (0xffffffffffffffff :: Word64) `shouldBe` L8.pack [0xCF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF] - - it "decodes empty array as ()" $ - unpack (pack ([] :: [Int])) `shouldBe` Just () - - describe "show" $ do - it "Foo" $ do - show (toObject defaultConfig Foo1) `shouldBe` "ObjectWord 0" - show (toObject defaultConfig $ Foo3 3) `shouldBe` "ObjectArray [ObjectWord 2,ObjectWord 3]" - show (toObject defaultConfig $ Foo3 (-3)) `shouldBe` "ObjectArray [ObjectWord 2,ObjectInt (-3)]" - show (toObject defaultConfig $ Foo8 3 5) `shouldBe` "ObjectArray [ObjectWord 7,ObjectArray [ObjectWord 3,ObjectWord 5]]" - show (toObject defaultConfig $ Foo8 (-3) (-5)) `shouldBe` "ObjectArray [ObjectWord 7,ObjectArray [ObjectInt (-3),ObjectInt (-5)]]" - show (toObject defaultConfig $ Foo9 3 5 7) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]]" - show (toObject defaultConfig $ Foo9 (-3) (-5) 7) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectInt (-3),ObjectInt (-5),ObjectWord 7]]" - - it "TyConArgs" $ - show (toObject defaultConfig $ TyConArgs 3 5 7) `shouldBe` "ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]" - - it "Record" $ - show (toObject defaultConfig $ Record 3 5 "7") `shouldBe` "ObjectArray [ObjectWord 3,ObjectDouble 5.0,ObjectStr \"7\"]" +spec = MessagePackSpec.spec Packer diff --git a/test/Data/Result.hs b/test/Data/Result.hs deleted file mode 100644 --- a/test/Data/Result.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE StrictData #-} -module Data.Result - ( Result (..) - ) where - -import Control.Applicative (Applicative (..), (<$>), (<*>)) -import Control.Monad.Fail (MonadFail (..)) - -data Result a - = Success a - | Failure String - deriving (Read, Show, Eq, Functor) - -instance Applicative Result where - pure = Success - - Success f <*> x = fmap f x - Failure msg <*> _ = Failure msg - -instance Monad Result where - return = Success - - Success x >>= f = f x - Failure msg >>= _ = Failure msg - -instance MonadFail Result where - fail = Failure diff --git a/tools/msgpack-gen-sample.hs b/tools/msgpack-gen-sample.hs new file mode 100644 --- /dev/null +++ b/tools/msgpack-gen-sample.hs @@ -0,0 +1,48 @@ +module Main where + +import Control.Monad (when) +import qualified Data.ByteString.Lazy as L +import Data.Int (Int64) +import Data.MessagePack (Object (..), pack) +import Data.MessagePack.Arbitrary () +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 () + + +showBytes :: Int64 -> String +showBytes size + | size > 10 * (1024 * 1024) = show (size `div` (1024 * 1024)) <> " MiB" + | size > 10 * 1024 = show (size `div` 1024) <> " KiB" + | otherwise = show size <> " B" + + +showSpeed :: Int64 -> Double -> String +showSpeed size time = + show (fromIntegral (size `div` (1024 * 1024)) / time) <> " MiB/s" + + +main :: IO () +main = do + size:_ <- (++[30]) . map read <$> getArgs + + start <- getCurrentTime + hPutStrLn stderr "Generating sample..." + + sample@(ObjectArray array) <- ObjectArray <$> Gen.generate (Gen.resize size arbitrary) + when (sample == sample) $ -- force deep evaluation of the whole structure (kind of deepseq) + hPutStr stderr $ "Generated msgpack array of length " <> show (length array) + sampleTime <- getCurrentTime + hPutStrLn stderr $ " in " <> show (diffUTCTime sampleTime start) + + let packed = pack sample + hPutStr stderr $ "Message packed into " <> showBytes (L.length packed) + packTime <- getCurrentTime + hPutStrLn stderr $ " in " <> show (diffUTCTime packTime sampleTime) + + hPutStrLn stderr $ "Packing speed: " <> showSpeed (L.length packed) (realToFrac (diffUTCTime packTime sampleTime)) + + L.putStr packed