[Git][ghc/ghc][master] Make TYPE and CONSTRAINT not-apart

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
af6932d6 by Simon Peyton Jones at 2024-01-10T17:39:12-05:00
Make TYPE and CONSTRAINT not-apart

Issue #24279 showed up a bug in the logic in GHC.Core.Unify.unify_ty
which is supposed to make TYPE and CONSTRAINT be not-apart.

Easily fixed.

- - - - -


4 changed files:

- compiler/GHC/Core/Unify.hs
- + testsuite/tests/typecheck/should_fail/T24279.hs
- + testsuite/tests/typecheck/should_fail/T24279.stderr
- testsuite/tests/typecheck/should_fail/all.T


Changes:

=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -31,6 +31,7 @@ import GHC.Types.Var
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
 import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName )
+import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey )
 import GHC.Core.Type     hiding ( getTvSubstEnv )
 import GHC.Core.Coercion hiding ( getCvSubstEnv )
 import GHC.Core.TyCon
@@ -1149,8 +1150,10 @@ unify_ty env ty1 ty2 _kco
   -- TYPE and CONSTRAINT are not Apart
   -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim
   -- NB: at this point we know that the two TyCons do not match
-  | Just {} <- sORTKind_maybe ty1
-  , Just {} <- sORTKind_maybe ty2
+  | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1
+  , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2
+  , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) ||
+    (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey)
   = maybeApart MARTypeVsConstraint
     -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim
     -- Note [Type and Constraint are not apart]


=====================================
testsuite/tests/typecheck/should_fail/T24279.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE TypeFamilies #-}
+module T24279 where
+
+import GHC.Exts
+import Data.Kind
+
+type F :: (RuntimeRep -> Type) -> Type
+type family F a where
+  F TYPE = Int
+  F CONSTRAINT = Bool
+
+type G :: Type -> RuntimeRep -> Type
+type family G a where
+  G (a b) = a
+
+-- Should be rejected
+foo :: (F (G Constraint)) -> Bool
+foo x = x
+
+
+type family H a b where
+  H a a = Int
+  H a b = Bool
+
+-- Should be rejected
+bar1 :: H TYPE CONSTRAINT -> Int
+bar1 x = x
+
+-- Should be rejected
+bar2 :: H Type Constraint -> Int
+bar2 x = x


=====================================
testsuite/tests/typecheck/should_fail/T24279.stderr
=====================================
@@ -0,0 +1,19 @@
+
+T24279.hs:18:9: error: [GHC-83865]
+    • Couldn't match type ‘F CONSTRAINT’ with ‘Bool’
+      Expected: Bool
+        Actual: F (G Constraint)
+    • In the expression: x
+      In an equation for ‘foo’: foo x = x
+
+T24279.hs:27:10: error: [GHC-83865]
+    • Couldn't match expected type ‘Int’
+                  with actual type ‘H TYPE CONSTRAINT’
+    • In the expression: x
+      In an equation for ‘bar1’: bar1 x = x
+
+T24279.hs:31:10: error: [GHC-83865]
+    • Couldn't match expected type ‘Int’
+                  with actual type ‘H (*) Constraint’
+    • In the expression: x
+      In an equation for ‘bar2’: bar2 x = x


=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -711,3 +711,4 @@ test('T17940', normal, compile_fail, [''])
 test('ErrorIndexLinks', normal, compile_fail, ['-fprint-error-index-links=always'])
 test('T24064', normal, compile_fail, [''])
 test('T24298', normal, compile_fail, [''])
+test('T24279', normal, compile_fail, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/af6932d6c068361c6ae300d52e72fbe13f8e1f18

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/af6932d6c068361c6ae300d52e72fbe13f8e1f18
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240110/2346aa60/attachment-0001.html>