From 95dbb067cce6613925c8c3d77caf8c056a8c2de8 Mon Sep 17 00:00:00 2001 From: Benjamin Koch Date: Wed, 27 May 2020 01:27:21 +0200 Subject: [PATCH 1/2] Add test for generic put with 256 constructors --- binary.cabal | 1 + tests/Generic.hs | 28 ++++++++++++++++++++++++++++ tests/QC.hs | 8 ++++++++ 3 files changed, 37 insertions(+) create mode 100644 tests/Generic.hs diff --git a/binary.cabal b/binary.cabal index 288117ee..199a6cae 100644 --- a/binary.cabal +++ b/binary.cabal @@ -67,6 +67,7 @@ test-suite qc other-modules: Action Arbitrary + Generic build-depends: base >= 4.5.0.0 && < 5, base-orphans >=0.8.1 && <0.9, diff --git a/tests/Generic.hs b/tests/Generic.hs new file mode 100644 index 00000000..5694af32 --- /dev/null +++ b/tests/Generic.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Generic where + +import Data.Binary +import GHC.Generics +import Test.QuickCheck + +data Generic256 = + C00 | C01 | C02 | C03 | C04 | C05 | C06 | C07 | C08 | C09 | C0a | C0b | C0c | C0d | C0e | C0f + | C10 | C11 | C12 | C13 | C14 | C15 | C16 | C17 | C18 | C19 | C1a | C1b | C1c | C1d | C1e | C1f + | C20 | C21 | C22 | C23 | C24 | C25 | C26 | C27 | C28 | C29 | C2a | C2b | C2c | C2d | C2e | C2f + | C30 | C31 | C32 | C33 | C34 | C35 | C36 | C37 | C38 | C39 | C3a | C3b | C3c | C3d | C3e | C3f + | C40 | C41 | C42 | C43 | C44 | C45 | C46 | C47 | C48 | C49 | C4a | C4b | C4c | C4d | C4e | C4f + | C50 | C51 | C52 | C53 | C54 | C55 | C56 | C57 | C58 | C59 | C5a | C5b | C5c | C5d | C5e | C5f + | C60 | C61 | C62 | C63 | C64 | C65 | C66 | C67 | C68 | C69 | C6a | C6b | C6c | C6d | C6e | C6f + | C70 | C71 | C72 | C73 | C74 | C75 | C76 | C77 | C78 | C79 | C7a | C7b | C7c | C7d | C7e | C7f + | C80 | C81 | C82 | C83 | C84 | C85 | C86 | C87 | C88 | C89 | C8a | C8b | C8c | C8d | C8e | C8f + | C90 | C91 | C92 | C93 | C94 | C95 | C96 | C97 | C98 | C99 | C9a | C9b | C9c | C9d | C9e | C9f + | Ca0 | Ca1 | Ca2 | Ca3 | Ca4 | Ca5 | Ca6 | Ca7 | Ca8 | Ca9 | Caa | Cab | Cac | Cad | Cae | Caf + | Cb0 | Cb1 | Cb2 | Cb3 | Cb4 | Cb5 | Cb6 | Cb7 | Cb8 | Cb9 | Cba | Cbb | Cbc | Cbd | Cbe | Cbf + | Cc0 | Cc1 | Cc2 | Cc3 | Cc4 | Cc5 | Cc6 | Cc7 | Cc8 | Cc9 | Cca | Ccb | Ccc | Ccd | Cce | Ccf + | Cd0 | Cd1 | Cd2 | Cd3 | Cd4 | Cd5 | Cd6 | Cd7 | Cd8 | Cd9 | Cda | Cdb | Cdc | Cdd | Cde | Cdf + | Ce0 | Ce1 | Ce2 | Ce3 | Ce4 | Ce5 | Ce6 | Ce7 | Ce8 | Ce9 | Cea | Ceb | Cec | Ced | Cee | Cef + | Cf0 | Cf1 | Cf2 | Cf3 | Cf4 | Cf5 | Cf6 | Cf7 | Cf8 | Cf9 | Cfa | Cfb | Cfc | Cfd | Cfe | Cff + deriving (Eq, Enum, Bounded, Show, Generic, Binary) + +instance Arbitrary Generic256 where + arbitrary = oneof (map pure [minBound..maxBound]) diff --git a/tests/QC.hs b/tests/QC.hs index 776768f4..1bc160fd 100644 --- a/tests/QC.hs +++ b/tests/QC.hs @@ -40,6 +40,7 @@ import Test.QuickCheck hiding (total) import qualified Action (tests) import Arbitrary () +import Generic (Generic256) import Data.Binary import Data.Binary.Get import Data.Binary.Put @@ -528,6 +529,11 @@ prop_fixed_resolution_constr x = runGet get (runPut (fixedPut x)) == x ------------------------------------------------------------------------ +prop_Generic256 :: Generic256 -> Property +prop_Generic256 = roundTripWith put get + +------------------------------------------------------------------------ + type T a = a -> Property type B a = a -> Bool @@ -708,4 +714,6 @@ tests = ] #endif , testTypeable + , testGroup "Generic" + [ testProperty "Generic256" $ p prop_Generic256 ] ] From 29c5e511d225e99e69de34f8851df99eed62fafe Mon Sep 17 00:00:00 2001 From: Benjamin Koch Date: Wed, 27 May 2020 01:28:50 +0200 Subject: [PATCH 2/2] Use larger type if size doesn't fit. The current implementation uses the output type to store the number of constructors (e.g. parameter size of putSum). This will fail if we try to serialize a type with 256 constructors, which can be encoded in Word8 but its size does not. This is slightly inefficient: We could use Word8 if getSum and putSum were implemented differently (which would make them more complicated and probably slower). --- src/Data/Binary/Generic.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs index 89f67f28..c41d8988 100644 --- a/src/Data/Binary/Generic.hs +++ b/src/Data/Binary/Generic.hs @@ -83,7 +83,7 @@ instance Binary a => GBinaryGet (K1 i a) where -- encode the constructor. If it has 2^16 constructors or less it will -- use two bytes, and so on till 2^64-1. -#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) +#define GUARD(WORD) size <= fromIntegral (maxBound :: WORD) #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)