msgpack-binary 0.0.15 → 0.0.16
raw patch · 8 files changed
+150/−421 lines, 8 filesdep +msgpack-arbitrarydep +msgpack-testsuitedep +quickcheck-instancesdep −containersdep −hashabledep −unordered-containersdep ~msgpack-typesnew-component:exe:msgpack-gen-sample
Dependencies added: msgpack-arbitrary, msgpack-testsuite, quickcheck-instances, time
Dependencies removed: containers, hashable, unordered-containers
Dependency ranges changed: msgpack-types
Files
- bench/Data/MessagePackBench.hs +26/−2
- msgpack-binary.cabal +22/−11
- src/Data/MessagePack.hs +18/−16
- src/Data/MessagePack/Get.hs +5/−4
- src/Data/MessagePack/Put.hs +20/−19
- test/Data/MessagePackSpec.hs +11/−339
- test/Data/Result.hs +0/−30
- tools/msgpack-gen-sample.hs +48/−0
bench/Data/MessagePackBench.hs view
@@ -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` ())
msgpack-binary.cabal view
@@ -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
src/Data/MessagePack.hs view
@@ -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
src/Data/MessagePack/Get.hs view
@@ -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
src/Data/MessagePack/Put.hs view
@@ -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
test/Data/MessagePackSpec.hs view
@@ -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
− test/Data/Result.hs
@@ -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
+ tools/msgpack-gen-sample.hs view
@@ -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