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.3.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,9 +56,10 @@ hs-source-dirs: test main-is: testsuite.hs other-modules: - Data.MessagePack.Arbitrary + Data.MessagePack.TagsSpec Data.MessagePack.Types.AssocSpec Data.MessagePack.Types.ClassSpec + Test.QuickCheck.Instances.MessagePack ghc-options: -Wall -fno-warn-unused-imports @@ -75,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 @@ -30,7 +30,6 @@ , defaultConfig ) where -import Control.Applicative (Applicative, (<$>), (<*>)) import Control.Arrow ((***)) import Control.Monad.Validate (MonadValidate (..)) import qualified Data.ByteString as S @@ -45,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 (..)) 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,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} @@ -7,15 +6,14 @@ ( 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 qualified Data.Vector as V -import Data.Word (Word64, Word8) -import GHC.Generics (Generic) +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. diff --git a/test/Data/MessagePack/Arbitrary.hs b/test/Data/MessagePack/Arbitrary.hs deleted file mode 100644 --- a/test/Data/MessagePack/Arbitrary.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE Trustworthy #-} -module Data.MessagePack.Arbitrary () where - -import qualified Data.ByteString as S -import Data.MessagePack.Types (Object (..)) -import qualified Data.Text as T -import qualified Data.Vector as V -import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) -import qualified Test.QuickCheck.Gen as Gen - - -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 <$> (V.fromList <$> Gen.resize (n `div` 2) arbitrary) - , ObjectMap <$> (V.fromList <$> 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,37 +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.Arbitrary () -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,23 +84,6 @@ instance Arbitrary MyType where 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 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