From e4473b394ef292e8b5c7b8dabc9e42c7ad49ce1d Mon Sep 17 00:00:00 2001 From: konsumlamm Date: Tue, 24 Mar 2026 02:37:01 +0100 Subject: [PATCH 1/3] Fix Generic Binary instance for types with 256 constructors --- src/Data/Binary/Generic.hs | 32 +++++++++++++++++--------------- tests/QC.hs | 38 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 53 insertions(+), 17 deletions(-) diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs index a09644a..99a13c3 100644 --- a/src/Data/Binary/Generic.hs +++ b/src/Data/Binary/Generic.hs @@ -84,8 +84,8 @@ instance Binary a => GBinaryGet (K1 i a) where -- use two bytes, and so on till 2^64-1. #define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) -#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) -#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) +#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral (size - 1)) +#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral (size - 1)) instance ( GSumPut a, GSumPut b , SumSize a, SumSize b) => GBinaryPut (a :+: b) where @@ -111,8 +111,9 @@ sizeError s size = checkGetSum :: (Ord word, Num word, Bits word, GSumGet f) => word -> word -> Get (f a) -checkGetSum size code | code < size = getSum code size - | otherwise = fail "Unknown encoding for constructor" +checkGetSum maxCode code + | code <= maxCode = getSum code maxCode + | otherwise = fail "Unknown encoding for constructor" {-# INLINE checkGetSum #-} class GSumGet f where @@ -122,20 +123,21 @@ class GSumPut f where putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put instance (GSumGet a, GSumGet b) => GSumGet (a :+: b) where - getSum !code !size | code < sizeL = L1 <$> getSum code sizeL - | otherwise = R1 <$> getSum (code - sizeL) sizeR - where - sizeL = size `shiftR` 1 - sizeR = size - sizeL + getSum !code !maxCode + | code <= maxCodeL = L1 <$> getSum code maxCodeL + | otherwise = R1 <$> getSum (code - maxCodeL - 1) maxCodeR + where + maxCodeL = (maxCode - 1) `shiftR` 1 + maxCodeR = maxCode - maxCodeL - 1 {-# INLINE getSum #-} instance (GSumPut a, GSumPut b) => GSumPut (a :+: b) where - putSum !code !size s = case s of - L1 x -> putSum code sizeL x - R1 x -> putSum (code + sizeL) sizeR x - where - sizeL = size `shiftR` 1 - sizeR = size - sizeL + putSum !code !maxCode s = case s of + L1 x -> putSum code maxCodeL x + R1 x -> putSum (code + maxCodeL + 1) maxCodeR x + where + maxCodeL = (maxCode - 1) `shiftR` 1 + maxCodeR = maxCode - maxCodeL - 1 instance GBinaryGet a => GSumGet (C1 c a) where getSum _ _ = gget diff --git a/tests/QC.hs b/tests/QC.hs index fc1fdc7..c5b2b7a 100644 --- a/tests/QC.hs +++ b/tests/QC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-} +{-# LANGUAGE CPP, DeriveGeneric, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-} module Main ( main ) where #if MIN_VERSION_base(4,8,0) @@ -32,6 +32,7 @@ import Numeric.Natural #endif import GHC.Fingerprint +import GHC.Generics (Generic) import qualified Data.Fixed as Fixed @@ -182,7 +183,7 @@ atomicTypeReps = ] instance Arbitrary TypeRep where - arbitrary = oneof (map pure atomicTypeReps) + arbitrary = elements atomicTypeReps #else testTypeable :: Test testTypeable = testGroup "Skipping Typeable tests" [] @@ -529,6 +530,35 @@ prop_fixed_resolution_constr x = runGet get (runPut (fixedPut x)) == x ------------------------------------------------------------------------ +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 (Bounded, Enum, Eq, Generic, Show) + +instance Binary Generic256 + +instance Arbitrary Generic256 where + arbitrary = elements [minBound..maxBound] + +prop_Generic256 :: Generic256 -> Property +prop_Generic256 = roundTripWith put get + +------------------------------------------------------------------------ + type T a = a -> Property type B a = a -> Bool @@ -709,4 +739,8 @@ tests = ] #endif , testTypeable + + , testGroup "Generic" + [ testProperty "Generic256" $ prop_Generic256 + ] ] From 3aa0f9ae8ac60bce2e86e7d686964e1fe1fec232 Mon Sep 17 00:00:00 2001 From: konsumlamm Date: Tue, 24 Mar 2026 14:46:34 +0100 Subject: [PATCH 2/3] Keep `size` as `Word64` instead --- src/Data/Binary/Generic.hs | 40 +++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs index 99a13c3..cceb7f9 100644 --- a/src/Data/Binary/Generic.hs +++ b/src/Data/Binary/Generic.hs @@ -30,6 +30,7 @@ import Data.Binary.Get import Data.Binary.Put import Data.Bits import Data.Word +import Data.Proxy #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif @@ -84,8 +85,8 @@ instance Binary a => GBinaryGet (K1 i a) where -- use two bytes, and so on till 2^64-1. #define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) -#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral (size - 1)) -#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral (size - 1)) +#define PUTSUM(WORD) GUARD(WORD) = putSum (Proxy :: Proxy WORD) 0 size +#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum size . fromIntegral instance ( GSumPut a, GSumPut b , SumSize a, SumSize b) => GBinaryPut (a :+: b) where @@ -109,41 +110,40 @@ sizeError s size = ------------------------------------------------------------------------ -checkGetSum :: (Ord word, Num word, Bits word, GSumGet f) - => word -> word -> Get (f a) -checkGetSum maxCode code - | code <= maxCode = getSum code maxCode - | otherwise = fail "Unknown encoding for constructor" +checkGetSum :: (GSumGet f) => Word64 -> Word64 -> Get (f a) +checkGetSum size code + | code < size = getSum code size + | otherwise = fail "Unknown encoding for constructor" {-# INLINE checkGetSum #-} class GSumGet f where - getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) + getSum :: Word64 -> Word64 -> Get (f a) class GSumPut f where - putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put + putSum :: (Binary word, Num word) => Proxy word -> Word64 -> Word64 -> f a -> Put instance (GSumGet a, GSumGet b) => GSumGet (a :+: b) where - getSum !code !maxCode - | code <= maxCodeL = L1 <$> getSum code maxCodeL - | otherwise = R1 <$> getSum (code - maxCodeL - 1) maxCodeR + getSum !code !size + | code < sizeL = L1 <$> getSum code sizeL + | otherwise = R1 <$> getSum (code - sizeL) sizeR where - maxCodeL = (maxCode - 1) `shiftR` 1 - maxCodeR = maxCode - maxCodeL - 1 + sizeL = size `shiftR` 1 + sizeR = size - sizeL {-# INLINE getSum #-} instance (GSumPut a, GSumPut b) => GSumPut (a :+: b) where - putSum !code !maxCode s = case s of - L1 x -> putSum code maxCodeL x - R1 x -> putSum (code + maxCodeL + 1) maxCodeR x + putSum p !code !size s = case s of + L1 x -> putSum p code sizeL x + R1 x -> putSum p (code + sizeL) sizeR x where - maxCodeL = (maxCode - 1) `shiftR` 1 - maxCodeR = maxCode - maxCodeL - 1 + sizeL = size `shiftR` 1 + sizeR = size - sizeL instance GBinaryGet a => GSumGet (C1 c a) where getSum _ _ = gget instance GBinaryPut a => GSumPut (C1 c a) where - putSum !code _ x = put code <> gput x + putSum (_ :: Proxy word) !code _ x = put (fromIntegral code :: word) <> gput x ------------------------------------------------------------------------ From edfceaa368f2a33834f741033c109f6fa2bb203b Mon Sep 17 00:00:00 2001 From: konsumlamm Date: Tue, 24 Mar 2026 19:15:06 +0100 Subject: [PATCH 3/3] Inline `putSum` for `:+:` --- src/Data/Binary/Generic.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs index cceb7f9..5e28ffb 100644 --- a/src/Data/Binary/Generic.hs +++ b/src/Data/Binary/Generic.hs @@ -138,6 +138,7 @@ instance (GSumPut a, GSumPut b) => GSumPut (a :+: b) where where sizeL = size `shiftR` 1 sizeR = size - sizeL + {-# INLINE putSum #-} instance GBinaryGet a => GSumGet (C1 c a) where getSum _ _ = gget