Skip to content

Commit 88a82ba

Browse files
konsumlammkonsumlamm
authored
Fix Generic Binary instance for types with 256 constructors (#228)
1 parent 00042bd commit 88a82ba

2 files changed

Lines changed: 59 additions & 22 deletions

File tree

‎src/Data/Binary/Generic.hs‎

Lines changed: 23 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ import Data.Binary.Get
3030
import Data.Binary.Put
3131
import Data.Bits
3232
import Data.Word
33+
import Data.Proxy
3334
#if !MIN_VERSION_base(4,11,0)
3435
import Data.Monoid ((<>))
3536
#endif
@@ -84,8 +85,8 @@ instance Binary a => GBinaryGet (K1 i a) where
8485
-- use two bytes, and so on till 2^64-1.
8586

8687
#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)
87-
#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)
88-
#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)
88+
#define PUTSUM(WORD) GUARD(WORD) = putSum (Proxy :: Proxy WORD) 0 size
89+
#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum size . fromIntegral
8990

9091
instance ( GSumPut a, GSumPut b
9192
, SumSize a, SumSize b) => GBinaryPut (a :+: b) where
@@ -109,39 +110,41 @@ sizeError s size =
109110

110111
------------------------------------------------------------------------
111112

112-
checkGetSum :: (Ord word, Num word, Bits word, GSumGet f)
113-
=> word -> word -> Get (f a)
114-
checkGetSum size code | code < size = getSum code size
115-
| otherwise = fail "Unknown encoding for constructor"
113+
checkGetSum :: (GSumGet f) => Word64 -> Word64 -> Get (f a)
114+
checkGetSum size code
115+
| code < size = getSum code size
116+
| otherwise = fail "Unknown encoding for constructor"
116117
{-# INLINE checkGetSum #-}
117118

118119
class GSumGet f where
119-
getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)
120+
getSum :: Word64 -> Word64 -> Get (f a)
120121

121122
class GSumPut f where
122-
putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put
123+
putSum :: (Binary word, Num word) => Proxy word -> Word64 -> Word64 -> f a -> Put
123124

124125
instance (GSumGet a, GSumGet b) => GSumGet (a :+: b) where
125-
getSum !code !size | code < sizeL = L1 <$> getSum code sizeL
126-
| otherwise = R1 <$> getSum (code - sizeL) sizeR
127-
where
128-
sizeL = size `shiftR` 1
129-
sizeR = size - sizeL
126+
getSum !code !size
127+
| code < sizeL = L1 <$> getSum code sizeL
128+
| otherwise = R1 <$> getSum (code - sizeL) sizeR
129+
where
130+
sizeL = size `shiftR` 1
131+
sizeR = size - sizeL
130132
{-# INLINE getSum #-}
131133

132134
instance (GSumPut a, GSumPut b) => GSumPut (a :+: b) where
133-
putSum !code !size s = case s of
134-
L1 x -> putSum code sizeL x
135-
R1 x -> putSum (code + sizeL) sizeR x
136-
where
137-
sizeL = size `shiftR` 1
138-
sizeR = size - sizeL
135+
putSum p !code !size s = case s of
136+
L1 x -> putSum p code sizeL x
137+
R1 x -> putSum p (code + sizeL) sizeR x
138+
where
139+
sizeL = size `shiftR` 1
140+
sizeR = size - sizeL
141+
{-# INLINE putSum #-}
139142

140143
instance GBinaryGet a => GSumGet (C1 c a) where
141144
getSum _ _ = gget
142145

143146
instance GBinaryPut a => GSumPut (C1 c a) where
144-
putSum !code _ x = put code <> gput x
147+
putSum (_ :: Proxy word) !code _ x = put (fromIntegral code :: word) <> gput x
145148

146149
------------------------------------------------------------------------
147150

‎tests/QC.hs‎

Lines changed: 36 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# LANGUAGE CPP, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-}
1+
{-# LANGUAGE CPP, DeriveGeneric, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-}
22
module Main ( main ) where
33

44
#if MIN_VERSION_base(4,8,0)
@@ -32,6 +32,7 @@ import Numeric.Natural
3232
#endif
3333

3434
import GHC.Fingerprint
35+
import GHC.Generics (Generic)
3536

3637
import qualified Data.Fixed as Fixed
3738

@@ -182,7 +183,7 @@ atomicTypeReps =
182183
]
183184

184185
instance Arbitrary TypeRep where
185-
arbitrary = oneof (map pure atomicTypeReps)
186+
arbitrary = elements atomicTypeReps
186187
#else
187188
testTypeable :: Test
188189
testTypeable = testGroup "Skipping Typeable tests" []
@@ -529,6 +530,35 @@ prop_fixed_resolution_constr x = runGet get (runPut (fixedPut x)) == x
529530

530531
------------------------------------------------------------------------
531532

533+
data Generic256
534+
= C00 | C01 | C02 | C03 | C04 | C05 | C06 | C07 | C08 | C09 | C0a | C0b | C0c | C0d | C0e | C0f
535+
| C10 | C11 | C12 | C13 | C14 | C15 | C16 | C17 | C18 | C19 | C1a | C1b | C1c | C1d | C1e | C1f
536+
| C20 | C21 | C22 | C23 | C24 | C25 | C26 | C27 | C28 | C29 | C2a | C2b | C2c | C2d | C2e | C2f
537+
| C30 | C31 | C32 | C33 | C34 | C35 | C36 | C37 | C38 | C39 | C3a | C3b | C3c | C3d | C3e | C3f
538+
| C40 | C41 | C42 | C43 | C44 | C45 | C46 | C47 | C48 | C49 | C4a | C4b | C4c | C4d | C4e | C4f
539+
| C50 | C51 | C52 | C53 | C54 | C55 | C56 | C57 | C58 | C59 | C5a | C5b | C5c | C5d | C5e | C5f
540+
| C60 | C61 | C62 | C63 | C64 | C65 | C66 | C67 | C68 | C69 | C6a | C6b | C6c | C6d | C6e | C6f
541+
| C70 | C71 | C72 | C73 | C74 | C75 | C76 | C77 | C78 | C79 | C7a | C7b | C7c | C7d | C7e | C7f
542+
| C80 | C81 | C82 | C83 | C84 | C85 | C86 | C87 | C88 | C89 | C8a | C8b | C8c | C8d | C8e | C8f
543+
| C90 | C91 | C92 | C93 | C94 | C95 | C96 | C97 | C98 | C99 | C9a | C9b | C9c | C9d | C9e | C9f
544+
| Ca0 | Ca1 | Ca2 | Ca3 | Ca4 | Ca5 | Ca6 | Ca7 | Ca8 | Ca9 | Caa | Cab | Cac | Cad | Cae | Caf
545+
| Cb0 | Cb1 | Cb2 | Cb3 | Cb4 | Cb5 | Cb6 | Cb7 | Cb8 | Cb9 | Cba | Cbb | Cbc | Cbd | Cbe | Cbf
546+
| Cc0 | Cc1 | Cc2 | Cc3 | Cc4 | Cc5 | Cc6 | Cc7 | Cc8 | Cc9 | Cca | Ccb | Ccc | Ccd | Cce | Ccf
547+
| Cd0 | Cd1 | Cd2 | Cd3 | Cd4 | Cd5 | Cd6 | Cd7 | Cd8 | Cd9 | Cda | Cdb | Cdc | Cdd | Cde | Cdf
548+
| Ce0 | Ce1 | Ce2 | Ce3 | Ce4 | Ce5 | Ce6 | Ce7 | Ce8 | Ce9 | Cea | Ceb | Cec | Ced | Cee | Cef
549+
| Cf0 | Cf1 | Cf2 | Cf3 | Cf4 | Cf5 | Cf6 | Cf7 | Cf8 | Cf9 | Cfa | Cfb | Cfc | Cfd | Cfe | Cff
550+
deriving (Bounded, Enum, Eq, Generic, Show)
551+
552+
instance Binary Generic256
553+
554+
instance Arbitrary Generic256 where
555+
arbitrary = elements [minBound..maxBound]
556+
557+
prop_Generic256 :: Generic256 -> Property
558+
prop_Generic256 = roundTripWith put get
559+
560+
------------------------------------------------------------------------
561+
532562
type T a = a -> Property
533563
type B a = a -> Bool
534564

@@ -709,4 +739,8 @@ tests =
709739
]
710740
#endif
711741
, testTypeable
742+
743+
, testGroup "Generic"
744+
[ testProperty "Generic256" $ prop_Generic256
745+
]
712746
]

0 commit comments

Comments
 (0)