diff --git a/msgpack-types.cabal b/msgpack-types.cabal --- a/msgpack-types.cabal +++ b/msgpack-types.cabal @@ -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 diff --git a/src/Data/MessagePack/Tags.hs b/src/Data/MessagePack/Tags.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Tags.hs @@ -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 diff --git a/src/Data/MessagePack/Types/Assoc.hs b/src/Data/MessagePack/Types/Assoc.hs --- a/src/Data/MessagePack/Types/Assoc.hs +++ b/src/Data/MessagePack/Types/Assoc.hs @@ -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 diff --git a/src/Data/MessagePack/Types/Class.hs b/src/Data/MessagePack/Types/Class.hs --- a/src/Data/MessagePack/Types/Class.hs +++ b/src/Data/MessagePack/Types/Class.hs @@ -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" diff --git a/src/Data/MessagePack/Types/Generic.hs b/src/Data/MessagePack/Types/Generic.hs --- a/src/Data/MessagePack/Types/Generic.hs +++ b/src/Data/MessagePack/Types/Generic.hs @@ -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) diff --git a/src/Data/MessagePack/Types/Object.hs b/src/Data/MessagePack/Types/Object.hs --- a/src/Data/MessagePack/Types/Object.hs +++ b/src/Data/MessagePack/Types/Object.hs @@ -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) diff --git a/test/Data/MessagePack/TagsSpec.hs b/test/Data/MessagePack/TagsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/MessagePack/TagsSpec.hs @@ -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 diff --git a/test/Data/MessagePack/Types/AssocSpec.hs b/test/Data/MessagePack/Types/AssocSpec.hs --- a/test/Data/MessagePack/Types/AssocSpec.hs +++ b/test/Data/MessagePack/Types/AssocSpec.hs @@ -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 = diff --git a/test/Data/MessagePack/Types/ClassSpec.hs b/test/Data/MessagePack/Types/ClassSpec.hs --- a/test/Data/MessagePack/Types/ClassSpec.hs +++ b/test/Data/MessagePack/Types/ClassSpec.hs @@ -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 diff --git a/test/Test/QuickCheck/Instances/MessagePack.hs b/test/Test/QuickCheck/Instances/MessagePack.hs new file mode 100644 --- /dev/null +++ b/test/Test/QuickCheck/Instances/MessagePack.hs @@ -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