From 16e796abc3ca375bcee027013812c3ef36b5c9fa Mon Sep 17 00:00:00 2001 From: konsumlamm Date: Sat, 11 Apr 2026 23:49:15 +0200 Subject: [PATCH 1/3] Fix `TypeRep` (de)serialisation for GHC 8.2 --- src/Data/Binary/Class.hs | 15 +++++++++++---- tests/QC.hs | 2 +- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs index de2e2ba..4104c18 100644 --- a/src/Data/Binary/Class.hs +++ b/src/Data/Binary/Class.hs @@ -1013,11 +1013,8 @@ putTypeRep (App f x) = do putTypeRep f putTypeRep x #if __GLASGOW_HASKELL__ < 903 --- N.B. This pattern never matches, --- even on versions of GHC older than 9.3: +-- N.B. On newer versions of GHC, this pattern never matches: -- a `Fun` typerep will match with the `App` pattern. --- This match is kept solely for pattern-match warnings, --- which are incorrect on GHC prior to 9.3. putTypeRep (Fun arg res) = do put (3 :: Word8) putTypeRep arg @@ -1050,6 +1047,16 @@ getSomeTypeRep = do [ "Applied type: " ++ show f , "To argument: " ++ show x ] +#if __GLASGOW_HASKELL__ < 903 + 3 -> do SomeTypeRep arg <- getSomeTypeRep + SomeTypeRep res <- getSomeTypeRep + case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $ SomeTypeRep $ Fun arg res + Nothing -> failure "Kind mismatch" [] + Nothing -> failure "Kind mismatch" [] +#endif _ -> failure "Invalid SomeTypeRep" [] where failure description info = diff --git a/tests/QC.hs b/tests/QC.hs index c5b2b7a..b371b42 100644 --- a/tests/QC.hs +++ b/tests/QC.hs @@ -157,7 +157,7 @@ prop_Doublele = roundTripWith putDoublele getDoublele prop_Doublehost :: Double -> Property prop_Doublehost = roundTripWith putDoublehost getDoublehost -#if MIN_VERSION_base(4,11,0) +#if MIN_VERSION_base(4,10,0) testTypeable :: Test testTypeable = testProperty "TypeRep" prop_TypeRep From 218ff8530a4c31de329bef6cdb592efb079873da Mon Sep 17 00:00:00 2001 From: konsumlamm Date: Sun, 12 Apr 2026 13:30:46 +0200 Subject: [PATCH 2/3] Deserialize all TypeRep arrow representations --- src/Data/Binary/Class.hs | 21 ++++++++++++--------- tests/QC.hs | 9 ++++++++- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs index 4104c18..f949a54 100644 --- a/src/Data/Binary/Class.hs +++ b/src/Data/Binary/Class.hs @@ -6,6 +6,10 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} +#if MIN_VERSION_base(4,10,0) +{-# LANGUAGE MultiWayIf #-} +#endif + #if MIN_VERSION_base(4,16,0) #define HAS_TYPELITS_CHAR #endif @@ -87,7 +91,7 @@ import Data.List (unfoldr) import Type.Reflection import Type.Reflection.Unsafe import Data.Kind (Type) -import GHC.Exts (RuntimeRep(..), VecCount, VecElem) +import GHC.Exts (TYPE, RuntimeRep(..), VecCount, VecElem) #endif import qualified Data.ByteString as B #if MIN_VERSION_bytestring(0,10,4) @@ -1047,16 +1051,15 @@ getSomeTypeRep = do [ "Applied type: " ++ show f , "To argument: " ++ show x ] -#if __GLASGOW_HASKELL__ < 903 3 -> do SomeTypeRep arg <- getSomeTypeRep SomeTypeRep res <- getSomeTypeRep - case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of - Just HRefl -> - case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of - Just HRefl -> return $ SomeTypeRep $ Fun arg res - Nothing -> failure "Kind mismatch" [] - Nothing -> failure "Kind mismatch" [] -#endif + if + | App argkcon _ <- typeRepKind arg + , App reskcon _ <- typeRepKind res + , Just HRefl <- argkcon `eqTypeRep` (typeRep :: TypeRep TYPE) + , Just HRefl <- reskcon `eqTypeRep` (typeRep :: TypeRep TYPE) + -> return $ SomeTypeRep $ Fun arg res + | otherwise -> failure "Kind mismatch" [] _ -> failure "Invalid SomeTypeRep" [] where failure description info = diff --git a/tests/QC.hs b/tests/QC.hs index b371b42..465370f 100644 --- a/tests/QC.hs +++ b/tests/QC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveGeneric, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-} +{-# LANGUAGE CPP, DeriveGeneric, ScopedTypeVariables, DataKinds, TypeSynonymInstances, MagicHash, UnboxedTuples #-} module Main ( main ) where #if MIN_VERSION_base(4,8,0) @@ -31,6 +31,7 @@ import Data.Orphans () import Numeric.Natural #endif +import GHC.Exts (Array#, Word#) import GHC.Fingerprint import GHC.Generics (Generic) @@ -180,6 +181,12 @@ atomicTypeReps = , typeRep (Proxy :: Proxy ('Left Int)) , typeRep (Proxy :: Proxy (Either Int String)) , typeRep (Proxy :: Proxy (() -> ())) + , typeRep (Proxy :: Proxy (# #)) + , typeRep (Proxy :: Proxy (#,#)) + , typeRep (Proxy :: Proxy Word#) + , typeRep (Proxy :: Proxy (Word# -> Word#)) + , typeRep (Proxy :: Proxy Array#) + , typeRep (Proxy :: Proxy (Array# Int)) ] instance Arbitrary TypeRep where From 7e360ca387e6beb38ee1e03ffcb2c72c8f539694 Mon Sep 17 00:00:00 2001 From: konsumlamm Date: Sun, 12 Apr 2026 13:35:26 +0200 Subject: [PATCH 3/3] Update error messages --- src/Data/Binary/Class.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs index f949a54..72813b7 100644 --- a/src/Data/Binary/Class.hs +++ b/src/Data/Binary/Class.hs @@ -955,7 +955,7 @@ instance Binary RuntimeRep where 17 -> pure Word32Rep #endif #endif - _ -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag" + _ -> fail "Data.Binary.put @RuntimeRep: invalid tag" -- | @since 0.8.5.0 instance Binary TyCon where @@ -985,7 +985,7 @@ instance Binary KindRep where 3 -> KindRepFun <$> get <*> get 4 -> KindRepTYPE <$> get 5 -> KindRepTypeLit <$> get <*> get - _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag" + _ -> fail "Data.Binary.put @KindRep: invalid tag" -- | @since 0.8.5.0 instance Binary TypeLitSort where @@ -1002,7 +1002,7 @@ instance Binary TypeLitSort where #ifdef HAS_TYPELITS_CHAR 2 -> pure TypeLitChar #endif - _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag" + _ -> fail "Data.Binary.put @TypeLitSort: invalid tag" putTypeRep :: TypeRep a -> Put putTypeRep rep -- Handle Type specially since it's so common @@ -1063,8 +1063,8 @@ getSomeTypeRep = do _ -> failure "Invalid SomeTypeRep" [] where failure description info = - fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ] - ++ map (" "++) info + fail $ unlines $ ["Data.Binary.getSomeTypeRep: " ++ description] + ++ map (" " ++) info instance Typeable a => Binary (TypeRep (a :: k)) where put = putTypeRep @@ -1073,7 +1073,7 @@ instance Typeable a => Binary (TypeRep (a :: k)) where case rep `eqTypeRep` expected of Just HRefl -> pure rep Nothing -> fail $ unlines - [ "GHCi.TH.Binary: Type mismatch" + [ "Data.Binary.get @(TypeRep a): Type mismatch" , " Deserialized type: " ++ show rep , " Expected type: " ++ show expected ]