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.0 synopsis: A Haskell implementation of MessagePack. homepage: http://msgpack.org/ license: BSD3 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 #-} -------------------------------------------------------------------- -- | @@ -162,9 +163,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 +224,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 +272,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/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,21 @@ {-# 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.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) -- | Object Representation of MessagePack data. @@ -37,9 +36,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 +46,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/Types/ClassSpec.hs b/test/Data/MessagePack/Types/ClassSpec.hs --- a/test/Data/MessagePack/Types/ClassSpec.hs +++ b/test/Data/MessagePack/Types/ClassSpec.hs @@ -19,6 +19,7 @@ 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, @@ -126,23 +127,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 +171,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 +187,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 +196,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