msgpack-binary-0.0.14: test/Data/MessagePackSpec.hs
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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 Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HashMap
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.Void (Void)
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 (Maybe Foo)
| Foo8 Int
| Foo9 Int Int
| Foo10 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
, Foo9 <$> arbitrary <*> arbitrary
, Foo10 <$> 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
coerce :: (MessagePack a, MessagePack b) => a -> Maybe b
coerce = unpack . pack
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 "
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 [0 :: Int, 1, 2, 3]) :: 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 "maybe int" $
property $ \(a :: (Maybe Int)) -> 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 "maybe int" $
property $ \(a :: Maybe Int) -> a `shouldBe` mid a
it "maybe nil" $
property $ \(a :: Maybe ()) -> a `shouldBe` mid a
it "maybe maybe int" $
property $ \(a :: Maybe (Maybe Int)) -> a `shouldBe` mid a
it "maybe bool" $
property $ \(a :: Maybe Bool) -> a `shouldBe` mid a
it "maybe double" $
property $ \(a :: Maybe Double) -> a `shouldBe` mid a
it "maybe string" $
property $ \(a :: Maybe String) -> a `shouldBe` mid a
it "maybe bytestring" $
property $ \(a :: Maybe S.ByteString) -> a `shouldBe` mid a
it "maybe lazy-bytestring" $
property $ \(a :: Maybe L.ByteString) -> a `shouldBe` mid a
it "maybe [int]" $
property $ \(a :: Maybe [Int]) -> a `shouldBe` mid a
it "maybe [string]" $
property $ \(a :: Maybe [String]) -> a `shouldBe` mid a
it "maybe (int, int)" $
property $ \(a :: Maybe (Int, Int)) -> a `shouldBe` mid a
it "maybe (int, int, int)" $
property $ \(a :: Maybe (Int, Int, Int)) -> a `shouldBe` mid a
it "maybe (int, int, int, int)" $
property $ \(a :: Maybe (Int, Int, Int, Int)) -> a `shouldBe` mid a
it "maybe (int, int, int, int, int)" $
property $ \(a :: Maybe (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a
it "maybe [(int, double)]" $
property $ \(a :: Maybe [(Int, Double)]) -> a `shouldBe` mid a
it "maybe [(string, string)]" $
property $ \(a :: Maybe [(String, String)]) -> a `shouldBe` mid a
it "maybe (Assoc [(string, int)])" $
property $ \(a :: Maybe (Assoc [(String, Int)])) -> a `shouldBe` mid a
it "either int float" $
property $ \(a :: Either Int Float) -> 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 Foo1) `shouldBe` "ObjectWord 0"
show (toObject $ Foo3 3) `shouldBe` "ObjectArray [ObjectWord 2,ObjectWord 3]"
show (toObject $ Foo3 (-3)) `shouldBe` "ObjectArray [ObjectWord 2,ObjectInt (-3)]"
show (toObject $ Foo9 3 5) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectWord 3,ObjectWord 5]]"
show (toObject $ Foo9 (-3) (-5)) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectInt (-3),ObjectInt (-5)]]"
show (toObject $ Foo10 3 5 7) `shouldBe` "ObjectArray [ObjectWord 9,ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]]"
show (toObject $ Foo10 (-3) (-5) 7) `shouldBe` "ObjectArray [ObjectWord 9,ObjectArray [ObjectInt (-3),ObjectInt (-5),ObjectWord 7]]"
it "TyConArgs" $
show (toObject $ TyConArgs 3 5 7) `shouldBe` "ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]"
it "Record" $
show (toObject $ Record 3 5 "7") `shouldBe` "ObjectArray [ObjectWord 3,ObjectDouble 5.0,ObjectStr \"7\"]"
voidTest :: Void -> Object
voidTest = toObject