Fix accidental unsoundness in Data.Typeable.Internal.mkTypeLitFromStringwip/T19288

An accidental use of `tcSymbol` instead of `tcNat` in the `TypeLitNat` case of
`mkTypeLitFromString` meant that it was possible to unsafely equate `Nat` with
`Symbol`. A consequence of this is that you could write `unsafeCoerce`, as
observed in #19288. This is fixed easily enough, thankfully.

Fixes #19288.

4 files changed, 36 insertions, 1 deletions

diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index 85abebf331..547fd13d62 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -990,7 +990,7 @@ mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep
 mkTypeLitFromString TypeLitSymbol s =
     SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Symbol)
 mkTypeLitFromString TypeLitNat s =
-    SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Nat)
+    SomeTypeRep $ (typeLitTypeRep s tcNat :: TypeRep Nat)
 
 tcSymbol :: TyCon
 tcSymbol = typeRepTyCon (typeRep @Symbol)
diff --git a/libraries/base/tests/T19288.hs b/libraries/base/tests/T19288.hs
new file mode 100644
index 0000000000..7bb5fd2616
--- /dev/null
+++ b/libraries/base/tests/T19288.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, Safe, TypeFamilies #-}
+
+module Main where
+
+import Data.Maybe
+import Data.Proxy
+import Type.Reflection
+import GHC.TypeLits
+
+data Dat (x :: Proxy 1) = MkD1
+
+evil :: Maybe (Nat :~~: Symbol)
+evil = eqTypeRep (case (typeRepKind (typeRep :: TypeRep Dat)) of
+                          (Fun (App _ x) _) -> typeRepKind x)
+                 (typeRep :: TypeRep Symbol)
+
+
+data family Cast k l r
+newtype instance Cast Nat l r = CastNat { runCastNat :: l }
+newtype instance Cast Symbol l r = CastSymbol { runCastSymbol :: r }
+
+{-# NOINLINE castHelper #-}
+castHelper :: Maybe (a :~~: b) -> Cast a l r -> Cast b l r
+castHelper (Just HRefl) = id
+castHelper Nothing      = error "No more bug!"
+
+cast :: a -> b
+cast = runCastSymbol . castHelper evil . CastNat
+
+main :: IO ()
+main = print (cast 'a' :: Int)
diff --git a/libraries/base/tests/T19288.stderr b/libraries/base/tests/T19288.stderr
new file mode 100644
index 0000000000..68f83bff83
--- /dev/null
+++ b/libraries/base/tests/T19288.stderr
@@ -0,0 +1,3 @@
+T19288: No more bug!
+CallStack (from HasCallStack):
+  error, called at T19288.hs:25:27 in main:Main
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index ac65224ef0..da828cb2c2 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -261,3 +261,4 @@ test('T17499', [collect_stats('bytes allocated',5)], compile_and_run, ['-O -w'])
 test('T16643', normal, compile_and_run, [''])
 test('clamp', normal, compile_and_run, [''])
 test('T18642', extra_run_opts('+RTS -T -RTS'), compile_and_run, ['-O2'])
+test('T19288', exit_code(1), compile_and_run, [''])