Add a missing representation polymorphism checkwip/repr-check

6 files changed, 71 insertions, 1 deletions

diff --git a/compiler/GHC/Tc/Utils/Concrete.hs-boot b/compiler/GHC/Tc/Utils/Concrete.hs-boot
new file mode 100644
index 0000000000..be8a2f63f6
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/Concrete.hs-boot
@@ -0,0 +1,11 @@
+module GHC.Tc.Utils.Concrete where
+
+import GHC.Utils.Misc      ( HasDebugCallStack )
+import GHC.Tc.Types        ( TcM )
+import GHC.Tc.Types.Origin ( FixedRuntimeRepContext )
+import GHC.Tc.Utils.TcType ( TcType )
+
+hasFixedRuntimeRep_syntactic :: HasDebugCallStack
+                             => FixedRuntimeRepContext
+                             -> TcType
+                             -> TcM ()
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index d0afe71560..3df247e911 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -115,6 +115,7 @@ import GHC.Tc.Types.Constraint
 import GHC.Tc.Types.Evidence
 import GHC.Tc.Utils.Monad        -- TcType, amongst others
 import GHC.Tc.Utils.TcType
+import {-# SOURCE #-} GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
 import GHC.Tc.Errors.Types
 import GHC.Tc.Errors.Ppr
 
@@ -556,7 +557,7 @@ expTypeToType (Infer inf_res) = inferResultToType inf_res
 
 inferResultToType :: InferResult -> TcM Type
 inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl
-                      , ir_ref = ref })
+                      , ir_ref = ref, ir_frr = mb_frr })
   = do { mb_inferred_ty <- readTcRef ref
        ; tau <- case mb_inferred_ty of
             Just ty -> do { ensureMonoType ty
@@ -564,6 +565,9 @@ inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl
                           ; return ty }
             Nothing -> do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
                           ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
+                          ; case mb_frr of
+                              Nothing -> return ()
+                              Just reason -> hasFixedRuntimeRep_syntactic reason tau
                             -- See Note [TcLevel of ExpType]
                           ; writeMutVar ref (Just tau)
                           ; return tau }
diff --git a/testsuite/tests/rep-poly/RepPolyPartialSig.hs b/testsuite/tests/rep-poly/RepPolyPartialSig.hs
new file mode 100644
index 0000000000..afaf14ecc7
--- /dev/null
+++ b/testsuite/tests/rep-poly/RepPolyPartialSig.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeFamilies, PartialTypeSignatures #-}
+module RepPolyPartialSig where
+
+import GHC.Exts
+
+type family A :: RuntimeRep
+
+f x = x :: (_ :: TYPE A)
diff --git a/testsuite/tests/rep-poly/RepPolyPartialSig.stderr b/testsuite/tests/rep-poly/RepPolyPartialSig.stderr
new file mode 100644
index 0000000000..095c374387
--- /dev/null
+++ b/testsuite/tests/rep-poly/RepPolyPartialSig.stderr
@@ -0,0 +1,13 @@
+
+RepPolyPartialSig.hs:8:7: error: [GHC-55287]
+    • The first pattern in the equation for ‘f’
+      does not have a fixed runtime representation.
+      Its type is:
+        p :: TYPE c0
+      Cannot unify ‘A’ with the type variable ‘c0’
+      because it is not a concrete ‘RuntimeRep’.
+    • In the expression: x :: (_ :: TYPE A)
+      In an equation for ‘f’: f x = x :: (_ :: TYPE A)
+    • Relevant bindings include
+        x :: p (bound at RepPolyPartialSig.hs:8:3)
+        f :: p -> w (bound at RepPolyPartialSig.hs:8:1)
diff --git a/testsuite/tests/rep-poly/RepPolyPatBind.stderr b/testsuite/tests/rep-poly/RepPolyPatBind.stderr
index 40637215fe..a600e83672 100644
--- a/testsuite/tests/rep-poly/RepPolyPatBind.stderr
+++ b/testsuite/tests/rep-poly/RepPolyPatBind.stderr
@@ -17,3 +17,36 @@ RepPolyPatBind.hs:18:5: error: [GHC-55287]
                 x, y :: a
                 (# x, y #) = undefined
               in x
+
+RepPolyPatBind.hs:18:8: error: [GHC-55287]
+    • The pattern binding does not have a fixed runtime representation.
+      Its type is:
+        (# a0, b0 #) :: TYPE (TupleRep [c0, c1])
+      Cannot unify ‘rep’ with the type variable ‘c0’
+      because it is not a concrete ‘RuntimeRep’.
+    • In the pattern: (# x, y #)
+      In a pattern binding: (# x, y #) = undefined
+      In the expression:
+        let
+          x, y :: a
+          (# x, y #) = undefined
+        in x
+    • Relevant bindings include
+        foo :: () -> a (bound at RepPolyPatBind.hs:15:1)
+
+RepPolyPatBind.hs:18:11: error: [GHC-55287]
+    • The pattern binding does not have a fixed runtime representation.
+      Its type is:
+        (# a0, b0 #) :: TYPE (TupleRep [c0, c1])
+      Cannot unify ‘rep’ with the type variable ‘c1’
+      because it is not a concrete ‘RuntimeRep’.
+    • In the pattern: (# x, y #)
+      In a pattern binding: (# x, y #) = undefined
+      In the expression:
+        let
+          x, y :: a
+          (# x, y #) = undefined
+        in x
+    • Relevant bindings include
+        x :: a (bound at RepPolyPatBind.hs:18:8)
+        foo :: () -> a (bound at RepPolyPatBind.hs:15:1)
diff --git a/testsuite/tests/rep-poly/all.T b/testsuite/tests/rep-poly/all.T
index 33044ae9fe..dd8a85c251 100644
--- a/testsuite/tests/rep-poly/all.T
+++ b/testsuite/tests/rep-poly/all.T
@@ -66,6 +66,7 @@ test('RepPolyMcGuard', normal, compile_fail, [''])
 test('RepPolyNewtypePat1', normal, compile_fail, [''])
 test('RepPolyNewtypePat2', normal, compile, [''])
 test('RepPolyNPlusK', normal, compile_fail, [''])
+test('RepPolyPartialSig', normal, compile_fail, [''])
 test('RepPolyPatBind', normal, compile_fail, [''])
 test('RepPolyPatSynArg', normal, compile_fail, [''])
 test('RepPolyPatSynRes', normal, compile_fail, [''])