Skip to content

Fix Generic Binary instance for types with 256 constructors #228

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
konsumlamm wants to merge 3 commits into
base: master
Choose a base branch
from
+59 −22
Open

Fix Generic Binary instance for types with 256 constructors #228

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
e4473b3
Fix Generic Binary instance for types with 256 constructors
konsumlamm Mar 24, 2026
3aa0f9a
Keep `size` as `Word64` instead
konsumlamm Mar 24, 2026
edfceaa
Inline `putSum` for `:+:`
konsumlamm Mar 24, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
43 changes: 23 additions & 20 deletions src/Data/Binary/Generic.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)
#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)
#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
Expand All @@ -109,39 +110,41 @@ 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 :: (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 !size | code < sizeL = L1 <$> getSum code sizeL
| otherwise = R1 <$> getSum (code - sizeL) sizeR
where
sizeL = size `shiftR` 1
sizeR = size - sizeL
getSum !code !size
| code < sizeL = L1 <$> getSum code sizeL
| otherwise = R1 <$> getSum (code - sizeL) sizeR
where
sizeL = size `shiftR` 1
sizeR = size - sizeL
{-# 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 p !code !size s = case s of
L1 x -> putSum p code sizeL x
R1 x -> putSum p (code + sizeL) sizeR x
where
sizeL = size `shiftR` 1
sizeR = size - sizeL
{-# INLINE putSum #-}

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

------------------------------------------------------------------------

Expand Down
38 changes: 36 additions & 2 deletions tests/QC.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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)
Expand All @@ -21,7 +21,7 @@
#endif
import Data.Int
import Data.Ratio
import Data.Typeable

Check warning on line 24 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (8.2.2) 

The import of ‘Data.Typeable’ is redundant

Check warning on line 24 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (8.0.2) 

The import of ‘Data.Typeable’ is redundant
import Data.Word
import System.IO.Unsafe

Expand All @@ -32,6 +32,7 @@
#endif

import GHC.Fingerprint
import GHC.Generics (Generic)

import qualified Data.Fixed as Fixed

Expand Down Expand Up @@ -181,8 +182,8 @@
, typeRep (Proxy :: Proxy (() -> ()))
]

instance Arbitrary TypeRep where

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (9.6.7) 

Orphan instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (8.6.5) 

Orphan instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (9.8.4) 

Orphan class instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (8.10.7) 

Orphan instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (9.12.2) 

Orphan class instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (9.2.8) 

Orphan instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (9.4.8) 

Orphan instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (8.4.4) 

Orphan instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (9.10.3) 

Orphan class instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (8.8.4) 

Orphan instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (9.14.1) 

Orphan class instance: instance Arbitrary TypeRep

Check warning on line 185 in tests/QC.hs

View workflow job for this annotation

GitHub Actions / build (9.0.2) 

Orphan instance: instance Arbitrary TypeRep
arbitrary = oneof (map pure atomicTypeReps)
arbitrary = elements atomicTypeReps
#else
testTypeable :: Test
testTypeable = testGroup "Skipping Typeable tests" []
Expand Down Expand Up @@ -529,6 +530,35 @@

------------------------------------------------------------------------

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

Expand Down Expand Up @@ -709,4 +739,8 @@
]
#endif
, testTypeable

, testGroup "Generic"
[ testProperty "Generic256" $ prop_Generic256
]
]
Loading