diff --git a/data-msgpack.cabal b/data-msgpack.cabal --- a/data-msgpack.cabal +++ b/data-msgpack.cabal @@ -1,5 +1,5 @@ name: data-msgpack -version: 0.0.8 +version: 0.0.9 synopsis: A Haskell implementation of MessagePack homepage: http://msgpack.org/ license: BSD3 @@ -18,10 +18,6 @@ since the original author is unreachable. This fork incorporates a number of bugfixes and is actively being developed. -extra-source-files: - bench/Data/MessagePack/IntBench.hs - bench/Data/MessagePackBench.hs - source-repository head type: git location: https://github.com/TokTok/hs-msgpack.git @@ -35,6 +31,9 @@ -fno-warn-unused-imports exposed-modules: Data.MessagePack + Data.MessagePack.Option + Data.MessagePack.Result + other-modules: Data.MessagePack.Assoc Data.MessagePack.Class Data.MessagePack.Generic @@ -42,7 +41,6 @@ Data.MessagePack.Instances Data.MessagePack.Object Data.MessagePack.Put - Data.MessagePack.Result build-depends: base < 5 , QuickCheck @@ -76,6 +74,10 @@ default-language: Haskell2010 hs-source-dirs: test main-is: testsuite.hs + other-modules: + Data.MessagePack.OptionSpec + Data.MessagePack.ResultSpec + Data.MessagePackSpec ghc-options: -Wall -fno-warn-unused-imports @@ -97,6 +99,9 @@ default-language: Haskell2010 hs-source-dirs: bench main-is: benchmark.hs + other-modules: + Data.MessagePack.IntBench + Data.MessagePackBench ghc-options: -Wall -fno-warn-unused-imports diff --git a/src/Data/MessagePack.hs b/src/Data/MessagePack.hs --- a/src/Data/MessagePack.hs +++ b/src/Data/MessagePack.hs @@ -34,6 +34,7 @@ import Data.MessagePack.Get as X import Data.MessagePack.Instances as X import Data.MessagePack.Object as X +import Data.MessagePack.Option as X import Data.MessagePack.Put as X diff --git a/src/Data/MessagePack/Object.hs b/src/Data/MessagePack/Object.hs --- a/src/Data/MessagePack/Object.hs +++ b/src/Data/MessagePack/Object.hs @@ -95,22 +95,10 @@ , ObjectWord <$> arbitrary , ObjectFloat <$> arbitrary , ObjectDouble <$> arbitrary - , ObjectStr <$> arbitrary - , ObjectBin <$> 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 + , ObjectExt <$> arbitrary <*> (S.pack <$> arbitrary) ] where negatives = Gen.choose (minBound, -1) - -instance Arbitrary S.ByteString where - arbitrary = S.pack <$> arbitrary - -instance Arbitrary L.ByteString where - arbitrary = L.pack <$> arbitrary - -instance Arbitrary T.Text where - arbitrary = T.pack <$> arbitrary - -instance Arbitrary LT.Text where - arbitrary = LT.pack <$> arbitrary diff --git a/src/Data/MessagePack/Option.hs b/src/Data/MessagePack/Option.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Option.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +module Data.MessagePack.Option + ( Option (..) + ) where + +import Control.Applicative (Alternative (..), Applicative (..), + (<$>)) +import Control.Monad (Monad (..), MonadPlus (..)) +import Data.Data (Data) +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) +import Data.Typeable (Typeable) +import Test.QuickCheck.Arbitrary (Arbitrary (..)) +import qualified Test.QuickCheck.Gen as Gen + +import Data.MessagePack.Class (MessagePack (..)) +import Data.MessagePack.Object (Object (..)) + + +data Option a + = None + | Some a + deriving (Eq, Ord, Show, Read, Foldable, Functor, Traversable, Data, Typeable) + +instance Applicative Option where + pure = Some + + Some f <*> m = fmap f m + None <*> _ = None + +instance Monad Option where + return = Some + fail _ = None + + None >>= _ = None + Some x >>= f = f x + +instance Alternative Option where + empty = None + + None <|> x = x + x <|> _ = x + +instance MonadPlus Option where + mzero = empty + mplus = (<|>) + +instance MessagePack a => MessagePack (Option a) where + toObject None = ObjectNil + toObject (Some a) = toObject a + + fromObject ObjectNil = return None + fromObject x = Some <$> fromObject x + +instance Arbitrary a => Arbitrary (Option a) where + arbitrary = Gen.oneof + [ pure None + , Some <$> arbitrary + ] diff --git a/test/Data/MessagePack/OptionSpec.hs b/test/Data/MessagePack/OptionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/MessagePack/OptionSpec.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Trustworthy #-} +module Data.MessagePack.OptionSpec where + +import Test.Hspec +import Test.QuickCheck + +import Control.Applicative (empty, pure, (<$>), (<*>), (<|>)) +import Control.Monad (mplus, mzero) +import qualified Data.MessagePack.Option as O + + +newtype F = F (Int -> O.Option Int) + +instance Show F where + show = const "" + +instance Arbitrary F where + arbitrary = F <$> arbitrary + + +-- | Checks that 'O.Option' satisfies the laws described in the 'Monad' and +-- 'Applicative' documentation. +-- +-- Also see: +-- https://wiki.haskell.org/Monad_laws +-- https://hackage.haskell.org/package/base-4.9.0.0/docs/Prelude.html#t:Applicative +spec :: Spec +spec = do + describe "Monad" $ do + it "satisfies left identity" $ + property $ \a (F f) -> + (return' a `bind'` f) `shouldBe` f a + + it "satisfies right identity" $ + property $ \m -> + (m `bind'` return') `shouldBe` m + + it "satisfies associativity" $ + property $ \m (F f) (F g) -> + ((m `bind'` f) `bind'` g) `shouldBe` (m `bind'` (\x -> f x `bind'` g)) + + it "supports 'fail'" $ + fail' "nope" `shouldBe` O.None + + describe "Applicative" $ do + it "satisfies identity" $ + property identity + + it "satisfies composition" $ + property $ \x y w -> do + composition O.None O.None w + composition O.None (pure (y *) ) w + composition (pure (x *) ) O.None w + composition (pure (x *) ) (pure (y *) ) w + + it "satisfies homomorphism" $ + property $ \x -> homomorphism (x *) + + it "satisfies interchange" $ + property $ \x y -> do + interchange O.None y + interchange (pure (x *) ) y + + describe "Alternative" $ do + it "chooses the left-most success" $ do + O.Some "a" <|> O.Some "b" `shouldBe` O.Some "a" + O.Some "a" <|> O.None `shouldBe` O.Some "a" + O.None <|> O.Some "b" `shouldBe` O.Some "b" + + it "chooses the right-most failure" $ + O.None <|> O.None `shouldBe` (O.None :: O.Option ()) + + describe "empty" $ + it "is a failure" $ + empty <|> O.Some "a" `shouldBe` O.Some "a" + + describe "MonadPlus" $ do + it "chooses the left-most success" $ do + O.Some "a" `mplus` O.Some "b" `shouldBe` O.Some "a" + O.Some "a" `mplus` O.None `shouldBe` O.Some "a" + O.None `mplus` O.Some "b" `shouldBe` O.Some "b" + + it "chooses the right-most failure" $ + O.None `mplus` O.None `shouldBe` (O.None :: O.Option ()) + + describe "mzero" $ + it "is a failure" $ + mzero `mplus` O.Some "a" `shouldBe` O.Some "a" + + where + -- + -- Aliases constrained to the Option monad. These also help avoid lint + -- warnings about using monad laws. + -- + + return' :: Int -> O.Option Int + return' = return + + bind' :: O.Option Int -> (Int -> O.Option Int) -> O.Option Int + bind' = (>>=) + + fail' :: String -> O.Option Int + fail' = fail + + pure' :: a -> O.Option a + pure' = pure + + -- + -- Applicative laws. + -- + + identity :: O.Option Int -> Expectation + identity v = + (pure' id <*> v) `shouldBe` v + + composition :: O.Option (Int -> Int) -> O.Option (Int -> Int) -> O.Option Int -> Expectation + composition u v w = + (pure' (.) <*> u <*> v <*> w) `shouldBe` (u <*> (v <*> w)) + + homomorphism :: (Int -> Int) -> Int -> Expectation + homomorphism h x = + (pure' h <*> pure' x) `shouldBe` pure' (h x) + + interchange :: O.Option (Int -> Int) -> Int -> Expectation + interchange u y = + (u <*> pure' y) `shouldBe` (pure' ($ y) <*> u) diff --git a/test/Data/MessagePack/ResultSpec.hs b/test/Data/MessagePack/ResultSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/MessagePack/ResultSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Trustworthy #-} +module Data.MessagePack.ResultSpec where + +import Test.Hspec +import Test.QuickCheck + +import Control.Applicative (empty, pure, (<$>), (<*>), (<|>)) +import qualified Data.MessagePack.Result as R + + +newtype F = F (Int -> R.Result Int) + +instance Show F where + show = const "" + +instance Arbitrary F where + arbitrary = F <$> arbitrary + + +-- | Checks that 'R.Result' satisfies the laws described in the 'Monad' and +-- 'Applicative' documentation. +-- +-- Also see: +-- https://wiki.haskell.org/Monad_laws +-- https://hackage.haskell.org/package/base-4.9.0.0/docs/Prelude.html#t:Applicative +spec :: Spec +spec = do + describe "Monad" $ do + it "satisfies left identity" $ + property $ \a (F f) -> + (return' a `bind'` f) `shouldBe` f a + + it "satisfies right identity" $ + property $ \m -> + (m `bind'` return') `shouldBe` m + + it "satisfies associativity" $ + property $ \m (F f) (F g) -> + ((m `bind'` f) `bind'` g) `shouldBe` (m `bind'` (\x -> f x `bind'` g)) + + it "supports 'fail'" $ + fail' "nope" `shouldBe` R.Failure "nope" + + describe "Applicative" $ do + it "satisfies identity" $ + property identity + + it "satisfies composition" $ + property $ \x y w -> do + composition (R.Failure "nope") (R.Failure "no way") w + composition (R.Failure "nope") (pure (y *) ) w + composition (pure (x *) ) (R.Failure "no way") w + composition (pure (x *) ) (pure (y *) ) w + + it "satisfies homomorphism" $ + property $ \x -> homomorphism (x *) + + it "satisfies interchange" $ + property $ \x y -> do + interchange (R.Failure "nope") y + interchange (pure (x *) ) y + + describe "Alternative" $ do + it "chooses the left-most success" $ do + R.Success "a" <|> R.Success "b" `shouldBe` R.Success "a" + R.Success "a" <|> R.Failure "b" `shouldBe` R.Success "a" + R.Failure "a" <|> R.Success "b" `shouldBe` R.Success "b" + + it "chooses the right-most failure" $ + R.Failure "a" <|> R.Failure "b" `shouldBe` (R.Failure "b" :: R.Result ()) + + describe "empty" $ + it "is a failure" $ + empty <|> R.Success "a" `shouldBe` R.Success "a" + + where + -- + -- Aliases constrained to the Result monad. These also help avoid lint + -- warnings about using monad laws. + -- + + return' :: Int -> R.Result Int + return' = return + + bind' :: R.Result Int -> (Int -> R.Result Int) -> R.Result Int + bind' = (>>=) + + fail' :: String -> R.Result Int + fail' = fail + + pure' :: a -> R.Result a + pure' = pure + + -- + -- Applicative laws. + -- + + identity :: R.Result Int -> Expectation + identity v = + (pure' id <*> v) `shouldBe` v + + composition :: R.Result (Int -> Int) -> R.Result (Int -> Int) -> R.Result Int -> Expectation + composition u v w = + (pure' (.) <*> u <*> v <*> w) `shouldBe` (u <*> (v <*> w)) + + homomorphism :: (Int -> Int) -> Int -> Expectation + homomorphism h x = + (pure' h <*> pure' x) `shouldBe` pure' (h x) + + interchange :: R.Result (Int -> Int) -> Int -> Expectation + interchange u y = + (u <*> pure' y) `shouldBe` (pure' ($ y) <*> u) diff --git a/test/Data/MessagePackSpec.hs b/test/Data/MessagePackSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/MessagePackSpec.hs @@ -0,0 +1,396 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# 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.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 +import qualified Data.MessagePack.Result as R + + +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 "Option Int" $ + property $ \(a :: Option 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