Backport decT/hdecT to Data.Typeable, decTypeRep to Type.Reflection

Addresses one check box in #24.
haskell-compat · Oct 10, 2023 · 0f1bed7 · 0f1bed7
1 parent 7fda1c5
commit 0f1bed7
Show file tree

Hide file tree

Showing 4 changed files with 59 additions and 3 deletions.
diff --git a/base-compat/CHANGES.markdown b/base-compat/CHANGES.markdown
@@ -5,6 +5,8 @@
  - Backport `getSolo` to `Data.Tuple.Compat` when building against
    `ghc-prim-0.8.0` (GHC 9.2) or later. To backport `getSolo` to older versions
    of GHC, import `Data.Tuple.Compat` from `base-compat-batteries` instead.
+ - Backport `decT` and `hdecT` to `Data.Typeable.Compat`
+ - Backport `decTypeRep` to `Type.Reflection.Compat`
 
 ## Changes in 0.13.0 [2023.03.10]
  - Sync with `base-4.18`/GHC 9.6

diff --git a/base-compat/README.markdown b/base-compat/README.markdown
@@ -166,6 +166,8 @@ So far the following is covered.
  * `unzip` to `Data.Functor.Compat`
  * `(!?)` and `unsnoc` to `Data.List.Compat`
  * `getSolo` to `Data.Tuple.Compat`
+ * `decT` and `hdecT` to `Data.Typeable.Compat`
+ * `decTypeRep` to `Type.Reflection.Compat`
 
 ## What is not covered
 

diff --git a/base-compat/src/Data/Typeable/Compat.hs b/base-compat/src/Data/Typeable/Compat.hs
@@ -2,27 +2,33 @@
 #if __GLASGOW_HASKELL__ >= 702
 {-# LANGUAGE Trustworthy #-}
 #endif
-#if MIN_VERSION_base(4,10,0) && !(MIN_VERSION_base(4,18,0))
+#if MIN_VERSION_base(4,10,0) && !(MIN_VERSION_base(4,19,0))
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 #endif
 module Data.Typeable.Compat (
   module Base
 #if MIN_VERSION_base(4,10,0)
 , heqT
+, decT
+, hdecT
 #endif
 ) where
 
 import Data.Typeable as Base
 
-#if MIN_VERSION_base(4,10,0) && !(MIN_VERSION_base(4,18,0))
+#if MIN_VERSION_base(4,10,0) && !(MIN_VERSION_base(4,19,0))
 import Prelude.Compat
 
+import Data.Void (Void)
 import qualified Type.Reflection.Compat as TR
 #endif
 
-#if MIN_VERSION_base(4,10,0) && !(MIN_VERSION_base(4,18,0))
+#if MIN_VERSION_base(4,10,0)
+# if !(MIN_VERSION_base(4,18,0))
 -- | Extract a witness of heterogeneous equality of two types
 --
 -- /Since: 4.18.0.0/
@@ -31,4 +37,24 @@ heqT = ta `TR.eqTypeRep` tb
   where
     ta = TR.typeRep :: TR.TypeRep a
     tb = TR.typeRep :: TR.TypeRep b
+# endif
+
+# if !(MIN_VERSION_base(4,19,0))
+-- | Decide an equality of two types
+--
+-- /Since: 4.19.0.0/
+decT :: forall a b. (Typeable a, Typeable b) => Either (a :~: b -> Void) (a :~: b)
+decT = case hdecT @a @b of
+  Right HRefl -> Right Refl
+  Left p      -> Left (\Refl -> p HRefl)
+
+-- | Decide heterogeneous equality of two types.
+--
+-- /Since: 4.19.0.0/
+hdecT :: forall a b. (Typeable a, Typeable b) => Either (a :~~: b -> Void) (a :~~: b)
+hdecT = ta `TR.decTypeRep` tb
+  where
+    ta = TR.typeRep :: TR.TypeRep a
+    tb = TR.typeRep :: TR.TypeRep b
+# endif
 #endif
diff --git a/base-compat/src/Type/Reflection/Compat.hs b/base-compat/src/Type/Reflection/Compat.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ViewPatterns #-}
 # if !(MIN_VERSION_base(4,11,0))
 {-# LANGUAGE TypeInType #-}
@@ -18,6 +19,7 @@ module Type.Reflection.Compat (
   module Base
 , withTypeable
 , pattern TypeRep
+, decTypeRep
 #endif
 ) where
 
@@ -31,8 +33,16 @@ import Type.Reflection as Base hiding (withTypeable)
 # if !(MIN_VERSION_base(4,11,0))
 import GHC.Exts (TYPE)
 import Type.Reflection (Typeable, TypeRep)
+# endif
+
+# if !(MIN_VERSION_base(4,19,0))
+import Data.Void (Void)
+import Prelude.Compat
+import Type.Reflection.Unsafe (typeRepFingerprint)
 import Unsafe.Coerce (unsafeCoerce)
+# endif
 
+# if !(MIN_VERSION_base(4,11,0))
 -- | Use a 'TypeRep' as 'Typeable' evidence.
 withTypeable :: forall (a :: k) (r :: TYPE rep). ()
              => TypeRep a -> (Typeable a => r) -> r
@@ -79,4 +89,20 @@ pattern TypeRep :: forall a. () => Typeable a => TypeRep a
 pattern TypeRep <- (typeableInstance -> TypeableInstance)
   where TypeRep = typeRep
 # endif
+
+# if !(MIN_VERSION_base(4,19,0))
+-- | Type equality decision
+--
+-- /Since: 4.19.0.0/
+decTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
+             TypeRep a -> TypeRep b -> Either (a :~~: b -> Void) (a :~~: b)
+decTypeRep a b
+  | sameTypeRep a b = Right (unsafeCoerce HRefl)
+  | otherwise       = Left (\HRefl -> errorWithoutStackTrace ("decTypeRep: Impossible equality proof " ++ show a ++ " :~: " ++ show b))
+{-# INLINEABLE decTypeRep #-}
+
+sameTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
+               TypeRep a -> TypeRep b -> Bool
+sameTypeRep a b = typeRepFingerprint a == typeRepFingerprint b
+# endif
 #endif