msgpack-types 0.2.1 → 0.3.2
raw patch · 10 files changed
Files
- msgpack-types.cabal +5/−2
- src/Data/MessagePack/Tags.hs +38/−0
- src/Data/MessagePack/Types/Assoc.hs +2/−7
- src/Data/MessagePack/Types/Class.hs +33/−33
- src/Data/MessagePack/Types/Generic.hs +0/−2
- src/Data/MessagePack/Types/Object.hs +11/−30
- test/Data/MessagePack/TagsSpec.hs +16/−0
- test/Data/MessagePack/Types/AssocSpec.hs +6/−3
- test/Data/MessagePack/Types/ClassSpec.hs +44/−57
- test/Test/QuickCheck/Instances/MessagePack.hs +33/−0
msgpack-types.cabal view
@@ -1,5 +1,5 @@ name: msgpack-types-version: 0.2.1+version: 0.3.2 synopsis: A Haskell implementation of MessagePack. homepage: http://msgpack.org/ license: BSD3@@ -30,6 +30,7 @@ -Wall -fno-warn-unused-imports exposed-modules:+ Data.MessagePack.Tags Data.MessagePack.Types other-modules: Data.MessagePack.Types.Assoc@@ -39,7 +40,6 @@ Data.MessagePack.Types.Object build-depends: base < 5- , QuickCheck , bytestring , containers , deepseq@@ -56,8 +56,10 @@ hs-source-dirs: test main-is: testsuite.hs other-modules:+ Data.MessagePack.TagsSpec Data.MessagePack.Types.AssocSpec Data.MessagePack.Types.ClassSpec+ Test.QuickCheck.Instances.MessagePack ghc-options: -Wall -fno-warn-unused-imports@@ -74,6 +76,7 @@ , hspec , monad-validate , msgpack-types+ , quickcheck-instances , text , unordered-containers , vector
+ src/Data/MessagePack/Tags.hs view
@@ -0,0 +1,38 @@+-- Generated file - DO NOT EDIT+-- To regenerate, run:+-- tools/gen-tags > src/Data/MessagePack/Tags.hs+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}+module Data.MessagePack.Tags where++pattern TAG_nil = 0xc0 -- 11000000+pattern TAG_false = 0xc2 -- 11000010+pattern TAG_true = 0xc3 -- 11000011+pattern TAG_bin_8 = 0xc4 -- 11000100+pattern TAG_bin_16 = 0xc5 -- 11000101+pattern TAG_bin_32 = 0xc6 -- 11000110+pattern TAG_ext_8 = 0xc7 -- 11000111+pattern TAG_ext_16 = 0xc8 -- 11001000+pattern TAG_ext_32 = 0xc9 -- 11001001+pattern TAG_float_32 = 0xca -- 11001010+pattern TAG_float_64 = 0xcb -- 11001011+pattern TAG_uint_8 = 0xcc -- 11001100+pattern TAG_uint_16 = 0xcd -- 11001101+pattern TAG_uint_32 = 0xce -- 11001110+pattern TAG_uint_64 = 0xcf -- 11001111+pattern TAG_int_8 = 0xd0 -- 11010000+pattern TAG_int_16 = 0xd1 -- 11010001+pattern TAG_int_32 = 0xd2 -- 11010010+pattern TAG_int_64 = 0xd3 -- 11010011+pattern TAG_fixext_1 = 0xd4 -- 11010100+pattern TAG_fixext_2 = 0xd5 -- 11010101+pattern TAG_fixext_4 = 0xd6 -- 11010110+pattern TAG_fixext_8 = 0xd7 -- 11010111+pattern TAG_fixext_16 = 0xd8 -- 11011000+pattern TAG_str_8 = 0xd9 -- 11011001+pattern TAG_str_16 = 0xda -- 11011010+pattern TAG_str_32 = 0xdb -- 11011011+pattern TAG_array_16 = 0xdc -- 11011100+pattern TAG_array_32 = 0xdd -- 11011101+pattern TAG_map_16 = 0xde -- 11011110+pattern TAG_map_32 = 0xdf -- 11011111
src/Data/MessagePack/Types/Assoc.hs view
@@ -21,10 +21,8 @@ ( Assoc (..) ) where -import Control.Applicative ((<$>))-import Control.DeepSeq (NFData)-import Data.Typeable (Typeable)-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)+import Control.DeepSeq (NFData)+import Data.Typeable (Typeable) -- not defined for general Functor for performance reason. -- (ie. you would want to write custom instances for each type using@@ -32,6 +30,3 @@ newtype Assoc a = Assoc { unAssoc :: a } deriving (Show, Read, Eq, Ord, Typeable, NFData)--instance Arbitrary a => Arbitrary (Assoc a) where- arbitrary = Assoc <$> arbitrary
src/Data/MessagePack/Types/Class.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ViewPatterns #-} -------------------------------------------------------------------- -- |@@ -29,7 +30,6 @@ , defaultConfig ) where -import Control.Applicative (Applicative, (<$>), (<*>)) import Control.Arrow ((***)) import Control.Monad.Validate (MonadValidate (..)) import qualified Data.ByteString as S@@ -44,8 +44,8 @@ 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 Data.Word (Word16, Word32, Word64,+ Word8) import GHC.Generics (Generic, Rep, from, to) import Data.MessagePack.Types.Assoc (Assoc (..))@@ -162,9 +162,9 @@ instance MessagePack () where toObject _ _ = ObjectNil fromObjectWith _ = \case- ObjectNil -> return ()- ObjectArray [] -> return ()- _ -> refute "invalid encoding for ()"+ ObjectNil -> return ()+ ObjectArray (V.toList -> []) -> return ()+ _ -> refute "invalid encoding for ()" instance MessagePack Bool where toObject _ = ObjectBool@@ -223,36 +223,36 @@ -- Instances for array-like data structures. instance MessagePack a => MessagePack [a] where- toObject cfg = ObjectArray . map (toObject cfg)+ toObject cfg = ObjectArray . V.fromList . map (toObject cfg) fromObjectWith cfg = \case- ObjectArray xs -> mapM (fromObjectWith cfg) xs- _ -> refute "invalid encoding for list"+ ObjectArray o -> mapM (fromObjectWith cfg) (V.toList o)+ _ -> refute "invalid encoding for list" instance MessagePack a => MessagePack (V.Vector a) where- toObject cfg = ObjectArray . map (toObject cfg) . V.toList+ toObject cfg = ObjectArray . V.map (toObject cfg) fromObjectWith cfg = \case- ObjectArray o -> V.fromList <$> mapM (fromObjectWith cfg) o+ ObjectArray o -> V.fromList <$> mapM (fromObjectWith cfg) (V.toList o) _ -> refute "invalid encoding for Vector" instance (MessagePack a, VU.Unbox a) => MessagePack (VU.Vector a) where- toObject cfg = ObjectArray . map (toObject cfg) . VU.toList+ toObject cfg = ObjectArray . V.map (toObject cfg) . V.fromList . VU.toList fromObjectWith cfg = \case- ObjectArray o -> VU.fromList <$> mapM (fromObjectWith cfg) o+ ObjectArray o -> VU.fromList . V.toList <$> V.mapM (fromObjectWith cfg) o _ -> refute "invalid encoding for Unboxed Vector" instance (MessagePack a, VS.Storable a) => MessagePack (VS.Vector a) where- toObject cfg = ObjectArray . map (toObject cfg) . VS.toList+ toObject cfg = ObjectArray . V.map (toObject cfg) . V.fromList . VS.toList fromObjectWith cfg = \case- ObjectArray o -> VS.fromList <$> mapM (fromObjectWith cfg) o+ ObjectArray o -> VS.fromList . V.toList <$> V.mapM (fromObjectWith cfg) o _ -> refute "invalid encoding for Storable Vector" -- Instances for map-like data structures. instance (MessagePack a, MessagePack b) => MessagePack (Assoc [(a, b)]) where- toObject cfg (Assoc xs) = ObjectMap $ map (toObject cfg *** toObject cfg) xs+ toObject cfg (Assoc xs) = ObjectMap . V.fromList $ map (toObject cfg *** toObject cfg) xs fromObjectWith cfg = \case ObjectMap xs ->- Assoc <$> mapM (\(k, v) -> (,) <$> fromObjectWith cfg k <*> fromObjectWith cfg v) xs+ Assoc <$> mapM (\(k, v) -> (,) <$> fromObjectWith cfg k <*> fromObjectWith cfg v) (V.toList xs) _ -> refute "invalid encoding for Assoc" instance (MessagePack k, MessagePack v, Ord k) => MessagePack (Map.Map k v) where@@ -271,41 +271,41 @@ -- Instances for various tuple arities. instance (MessagePack a1, MessagePack a2) => MessagePack (a1, a2) where- toObject cfg (a1, a2) = ObjectArray [toObject cfg a1, toObject cfg a2]- fromObjectWith cfg (ObjectArray [a1, a2]) = (,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2+ toObject cfg (a1, a2) = ObjectArray $ V.fromList [toObject cfg a1, toObject cfg a2]+ fromObjectWith cfg (ObjectArray (V.toList -> [a1, a2])) = (,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 fromObjectWith _ _ = refute "invalid encoding for tuple" instance (MessagePack a1, MessagePack a2, MessagePack a3) => MessagePack (a1, a2, a3) where- toObject cfg (a1, a2, a3) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3]- fromObjectWith cfg (ObjectArray [a1, a2, a3]) = (,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3+ toObject cfg (a1, a2, a3) = ObjectArray $ V.fromList [toObject cfg a1, toObject cfg a2, toObject cfg a3]+ fromObjectWith cfg (ObjectArray (V.toList -> [a1, a2, a3])) = (,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 fromObjectWith _ _ = refute "invalid encoding for tuple" instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4) => MessagePack (a1, a2, a3, a4) where- toObject cfg (a1, a2, a3, a4) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4]- fromObjectWith cfg (ObjectArray [a1, a2, a3, a4]) = (,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4+ toObject cfg (a1, a2, a3, a4) = ObjectArray $ V.fromList [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4]+ fromObjectWith cfg (ObjectArray (V.toList -> [a1, a2, a3, a4])) = (,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 fromObjectWith _ _ = refute "invalid encoding for tuple" instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5) => MessagePack (a1, a2, a3, a4, a5) where- toObject cfg (a1, a2, a3, a4, a5) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5]- fromObjectWith cfg (ObjectArray [a1, a2, a3, a4, a5]) = (,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5+ toObject cfg (a1, a2, a3, a4, a5) = ObjectArray $ V.fromList [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5]+ fromObjectWith cfg (ObjectArray (V.toList -> [a1, a2, a3, a4, a5])) = (,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 fromObjectWith _ _ = refute "invalid encoding for tuple" instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6) => MessagePack (a1, a2, a3, a4, a5, a6) where- toObject cfg (a1, a2, a3, a4, a5, a6) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6]- fromObjectWith cfg (ObjectArray [a1, a2, a3, a4, a5, a6]) = (,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6+ toObject cfg (a1, a2, a3, a4, a5, a6) = ObjectArray $ V.fromList [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6]+ fromObjectWith cfg (ObjectArray (V.toList -> [a1, a2, a3, a4, a5, a6])) = (,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6 fromObjectWith _ _ = refute "invalid encoding for tuple" instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7) => MessagePack (a1, a2, a3, a4, a5, a6, a7) where- toObject cfg (a1, a2, a3, a4, a5, a6, a7) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6, toObject cfg a7]- fromObjectWith cfg (ObjectArray [a1, a2, a3, a4, a5, a6, a7]) = (,,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6 <*> fromObjectWith cfg a7+ toObject cfg (a1, a2, a3, a4, a5, a6, a7) = ObjectArray $ V.fromList [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6, toObject cfg a7]+ fromObjectWith cfg (ObjectArray (V.toList -> [a1, a2, a3, a4, a5, a6, a7])) = (,,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6 <*> fromObjectWith cfg a7 fromObjectWith _ _ = refute "invalid encoding for tuple" instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8) => MessagePack (a1, a2, a3, a4, a5, a6, a7, a8) where- toObject cfg (a1, a2, a3, a4, a5, a6, a7, a8) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6, toObject cfg a7, toObject cfg a8]- fromObjectWith cfg (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8]) = (,,,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6 <*> fromObjectWith cfg a7 <*> fromObjectWith cfg a8+ toObject cfg (a1, a2, a3, a4, a5, a6, a7, a8) = ObjectArray $ V.fromList [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6, toObject cfg a7, toObject cfg a8]+ fromObjectWith cfg (ObjectArray (V.toList -> [a1, a2, a3, a4, a5, a6, a7, a8])) = (,,,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6 <*> fromObjectWith cfg a7 <*> fromObjectWith cfg a8 fromObjectWith _ _ = refute "invalid encoding for tuple" instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8, MessagePack a9) => MessagePack (a1, a2, a3, a4, a5, a6, a7, a8, a9) where- toObject cfg (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6, toObject cfg a7, toObject cfg a8, toObject cfg a9]- fromObjectWith cfg (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = (,,,,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6 <*> fromObjectWith cfg a7 <*> fromObjectWith cfg a8 <*> fromObjectWith cfg a9+ toObject cfg (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ObjectArray $ V.fromList [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6, toObject cfg a7, toObject cfg a8, toObject cfg a9]+ fromObjectWith cfg (ObjectArray (V.toList -> [a1, a2, a3, a4, a5, a6, a7, a8, a9])) = (,,,,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6 <*> fromObjectWith cfg a7 <*> fromObjectWith cfg a8 <*> fromObjectWith cfg a9 fromObjectWith _ _ = refute "invalid encoding for tuple"
src/Data/MessagePack/Types/Generic.hs view
@@ -14,8 +14,6 @@ {-# LANGUAGE UndecidableInstances #-} module Data.MessagePack.Types.Generic () where -import Control.Applicative (Applicative, (<$>), (<*>))-import Control.Monad ((>=>)) import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put) import Control.Monad.Validate (MonadValidate, refute)
src/Data/MessagePack/Types/Object.hs view
@@ -1,22 +1,19 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE StrictData #-}+{-# LANGUAGE Trustworthy #-} module Data.MessagePack.Types.Object ( Object (..) ) where -import Control.Applicative ((<$>), (<*>))-import Control.DeepSeq (NFData (..))-import qualified Data.ByteString as S-import Data.Int (Int64)-import qualified Data.Text as T-import Data.Typeable (Typeable)-import Data.Word (Word64, Word8)-import GHC.Generics (Generic)-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)-import qualified Test.QuickCheck.Gen as Gen+import Control.DeepSeq (NFData (..))+import qualified Data.ByteString as S+import Data.Int (Int64)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import qualified Data.Vector as V+import Data.Word (Word64, Word8)+import GHC.Generics (Generic) -- | Object Representation of MessagePack data.@@ -37,9 +34,9 @@ -- ^ extending Raw type represents a UTF-8 string | ObjectBin S.ByteString -- ^ extending Raw type represents a byte array- | ObjectArray [Object]+ | ObjectArray (V.Vector Object) -- ^ represents a sequence of objects- | ObjectMap [(Object, Object)]+ | ObjectMap (V.Vector (Object, Object)) -- ^ represents key-value pairs of objects | ObjectExt {-# UNPACK #-} Word8 S.ByteString -- ^ represents a tuple of an integer and a byte array where@@ -47,19 +44,3 @@ deriving (Read, Show, Eq, Ord, Typeable, Generic) instance NFData Object--instance Arbitrary Object where- arbitrary = Gen.sized $ \n -> Gen.oneof- [ pure ObjectNil- , ObjectBool <$> arbitrary- , ObjectInt <$> negatives- , ObjectWord <$> arbitrary- , ObjectFloat <$> arbitrary- , ObjectDouble <$> arbitrary- , ObjectStr <$> (T.pack <$> arbitrary)- , ObjectBin <$> (S.pack <$> arbitrary)- , ObjectArray <$> Gen.resize (n `div` 2) arbitrary- , ObjectMap <$> Gen.resize (n `div` 4) arbitrary- , ObjectExt <$> arbitrary <*> (S.pack <$> arbitrary)- ]- where negatives = Gen.choose (minBound, -1)
+ test/Data/MessagePack/TagsSpec.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE LambdaCase #-}+module Data.MessagePack.TagsSpec where++import Data.MessagePack.Tags+import Test.Hspec (Spec, describe, it, shouldSatisfy)++spec :: Spec+spec =+ describe "Assoc" $+ it "has a working Read/Show implementation" $ do+ (TAG_nil :: Int) `shouldSatisfy` \case+ TAG_nil -> True+ _ -> False+ (TAG_nil :: Integer) `shouldSatisfy` \case+ TAG_nil -> True+ _ -> False
test/Data/MessagePack/Types/AssocSpec.hs view
@@ -2,9 +2,12 @@ {-# LANGUAGE Trustworthy #-} module Data.MessagePack.Types.AssocSpec where -import Data.MessagePack.Types (Assoc (..))-import Test.Hspec (Spec, describe, it, shouldBe)-import Test.QuickCheck (Arbitrary (..), property)+import Data.MessagePack.Types (Assoc (..))+import Test.Hspec (Spec, describe, it,+ shouldBe)+import Test.QuickCheck (Arbitrary (..),+ property)+import Test.QuickCheck.Instances.MessagePack () spec :: Spec spec =
test/Data/MessagePack/Types/ClassSpec.hs view
@@ -7,36 +7,40 @@ {-# LANGUAGE Trustworthy #-} module Data.MessagePack.Types.ClassSpec where -import Control.Applicative (empty, pure, (<$>), (<*>),- (<|>))-import Control.Monad (mplus, mzero)-import Control.Monad.Validate (MonadValidate (..),- runValidate)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.HashMap.Strict as HashMap-import Data.Hashable (Hashable)-import Data.Int (Int16, Int32, Int64, Int8)-import qualified Data.IntMap.Strict as IntMap-import qualified Data.Map as Map-import Data.MessagePack.Types (Assoc (..),- MessagePack (..),- Object (..), defaultConfig,- errorMessages)-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-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 Test.Hspec (Spec, describe, it,- shouldBe, shouldSatisfy)-import Test.QuickCheck (Arbitrary (..),- genericShrink, property,- withMaxSuccess)-import Test.QuickCheck.Arbitrary.Generic (genericArbitrary)+import Control.Applicative (empty, pure, (<$>),+ (<*>), (<|>))+import Control.Monad (mplus, mzero)+import Control.Monad.Validate (MonadValidate (..),+ runValidate)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.HashMap.Strict as HashMap+import Data.Hashable (Hashable)+import Data.Int (Int16, Int32, Int64,+ Int8)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map as Map+import Data.MessagePack.Types (Assoc (..),+ MessagePack (..),+ Object (..),+ defaultConfig,+ errorMessages)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+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 Test.Hspec (Spec, describe, it,+ shouldBe, shouldSatisfy)+import Test.QuickCheck (Arbitrary (..),+ genericShrink, property,+ withMaxSuccess)+import Test.QuickCheck.Arbitrary.Generic (genericArbitrary)+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Instances.MessagePack () data MyType = SequenceTyCon Int String Int Int@@ -81,24 +85,7 @@ arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary BS.ByteString where- arbitrary = BS.pack . take 10 <$> arbitrary-instance Arbitrary LBS.ByteString where- arbitrary = LBS.pack . take 10 <$> arbitrary-instance Arbitrary Text.Text where- arbitrary = Text.pack . take 10 <$> arbitrary-instance Arbitrary LText.Text where- arbitrary = LText.pack . take 10 <$> 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 a, Hashable a, Eq a, Arbitrary b) => Arbitrary (HashMap.HashMap a b) where- arbitrary = HashMap.fromList <$> arbitrary - type Result a = Either [String] a decode :: MessagePack a => Object -> Result a@@ -126,23 +113,23 @@ it "produces msgpack values as expected" $ do toObject defaultConfig (SequenceTyCon 111 "hello" 2 3)- `shouldBe` ObjectArray+ `shouldBe` ObjectArray (V.fromList [ ObjectWord 0- , ObjectArray [ObjectWord 111, ObjectStr "hello", ObjectWord 2, ObjectWord 3]- ]+ , ObjectArray (V.fromList [ObjectWord 111, ObjectStr "hello", ObjectWord 2, ObjectWord 3])+ ]) toObject defaultConfig EnumTyCon `shouldBe` ObjectWord 1 toObject defaultConfig (RecordTyCon 222)- `shouldBe` ObjectArray [ObjectWord 2, ObjectWord 222]+ `shouldBe` ObjectArray (V.fromList [ObjectWord 2, ObjectWord 222]) describe "MessagePack" $ do it "handles wrong encodings correctly" $ do- (decode $ ObjectArray [ObjectWord 1, ObjectWord 222] :: Result MyType)+ (decode $ ObjectArray (V.fromList [ObjectWord 1, ObjectWord 222]) :: Result MyType) `shouldBe` Left ["invalid encoding for custom unit type"] (decode ObjectNil :: Result MyType) `shouldBe` Left ["invalid encoding for tuple"]- (decode $ ObjectArray [ObjectWord 99999] :: Result MyType)+ (decode $ ObjectArray (V.fromList [ObjectWord 99999]) :: Result MyType) `shouldBe` Left ["invalid encoding for tuple"]- (decode $ ObjectArray [] :: Result MyType)+ (decode $ ObjectArray V.empty :: Result MyType) `shouldBe` Left ["invalid encoding for tuple"] (decode ObjectNil :: Result Int64) `shouldBe` Left ["invalid encoding for integer type"]@@ -170,7 +157,7 @@ `shouldBe` Left ["invalid encoding for Assoc"] (decode ObjectNil :: Result Word64) `shouldBe` Left ["invalid encoding for integer type"]- (decode (ObjectArray [ObjectWord 0]) :: Result ())+ (decode (ObjectArray (V.fromList [ObjectWord 0])) :: Result ()) `shouldBe` Left ["invalid encoding for ()"] (decode ObjectNil :: Result (Int, Int)) `shouldBe` Left ["invalid encoding for tuple"]@@ -186,7 +173,7 @@ `shouldBe` Left ["invalid encoding for tuple"] (decode ObjectNil :: Result (Int, Int, Int, Int, Int, Int, Int, Int)) `shouldBe` Left ["invalid encoding for tuple"]- (decode $ ObjectArray [ObjectNil, ObjectNil] :: Result (Int, String))+ (decode $ ObjectArray (V.fromList [ObjectNil, ObjectNil]) :: Result (Int, String)) `shouldBe` Left ["invalid encoding for integer type", "invalid encoding for Text"] it "has a working Read/Show implementation" $ property $ \(x :: Object) ->@@ -195,7 +182,7 @@ it "can parse both nil and [] as ()" $ do (decode ObjectNil :: Result ()) `shouldBe` Right ()- (decode (ObjectArray []) :: Result ())+ (decode (ObjectArray V.empty) :: Result ()) `shouldBe` Right () it "can parse ints and doubles as floats" $ do
+ test/Test/QuickCheck/Instances/MessagePack.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE Trustworthy #-}+module Test.QuickCheck.Instances.MessagePack () where++import qualified Data.ByteString as S+import Data.MessagePack.Types (Assoc (..), Object (..))+import qualified Data.Text as T+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)+import qualified Test.QuickCheck.Gen as Gen+import Test.QuickCheck.Instances.ByteString ()+import Test.QuickCheck.Instances.Vector ()+++instance Arbitrary Object where+ arbitrary = Gen.sized $ \n -> Gen.oneof+ [ pure ObjectNil+ , ObjectBool <$> arbitrary+ , ObjectInt <$> negatives+ , ObjectWord <$> arbitrary+ , ObjectFloat <$> arbitrary+ , ObjectDouble <$> arbitrary+ , ObjectStr <$> (T.pack <$> arbitrary)+ , ObjectBin <$> (S.pack <$> arbitrary)+ , ObjectArray <$> Gen.resize (n `div` 2) arbitrary+ , ObjectMap <$> Gen.resize (n `div` 4) arbitrary+ , ObjectExt <$> arbitrary <*> arbitrary+ ]+ where negatives = Gen.choose (minBound, -1)+++instance Arbitrary a => Arbitrary (Assoc a) where+ arbitrary = Assoc <$> arbitrary