Fix #16114 by adding a validity check to rnClsInstDecl

6 files changed, 35 insertions, 27 deletions

diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index ca35e941fb..e5fe3a3a31 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -648,13 +648,27 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                            , cid_sigs = uprags, cid_tyfam_insts = ats
                            , cid_overlap_mode = oflag
                            , cid_datafam_insts = adts })
-  = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty
+  = do { (inst_ty', inst_fvs)
+           <- rnHsSigType (GenericCtx $ text "an instance declaration") inst_ty
        ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
-       ; let cls = case hsTyGetAppHead_maybe head_ty' of
-                     Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
-                     Just (dL->L _ cls) -> cls
-                     -- rnLHsInstType has added an error message
-                     -- if hsTyGetAppHead_maybe fails
+       ; cls <-
+           case hsTyGetAppHead_maybe head_ty' of
+             Just (dL->L _ cls) -> pure cls
+             Nothing -> do
+               -- The instance is malformed. We'd still like
+               -- to make *some* progress (rather than failing outright), so
+               -- we report an error and continue for as long as we can.
+               -- Importantly, this error should be thrown before we reach the
+               -- typechecker, lest we encounter different errors that are
+               -- hopelessly confusing (such as the one in Trac #16114).
+               addErrAt (getLoc (hsSigType inst_ty)) $
+                 hang (text "Illegal class instance:" <+> quotes (ppr inst_ty))
+                    2 (vcat [ text "Class instances must be of the form"
+                            , nest 2 $ text "context => C ty_1 ... ty_n"
+                            , text "where" <+> quotes (char 'C')
+                              <+> text "is a class"
+                            ])
+               pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))
 
           -- Rename the bindings
           -- The typechecker (not the renamer) checks that all
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index f66c1bd29f..3703f1ac63 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -15,7 +15,6 @@ module RnTypes (
         rnHsKind, rnLHsKind, rnLHsTypeArgs,
         rnHsSigType, rnHsWcType,
         HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
-        rnLHsInstType,
         newTyVarNameRn,
         rnConDeclFields,
         rnLTyVar,
@@ -374,12 +373,6 @@ rnImplicitBndrs bind_free_tvs
            , text "Suggested fix: add" <+>
              quotes (text "forall" <+> hsep (map ppr kvs) <> char '.') ]
 
-rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
--- Rename the type in an instance.
--- The 'doc_str' is "an instance declaration".
--- Do not try to decompose the inst_ty in case it is malformed
-rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
-
 {- ******************************************************
 *                                                       *
            LHsType and HsType
diff --git a/testsuite/tests/rename/should_fail/T16114.hs b/testsuite/tests/rename/should_fail/T16114.hs
new file mode 100644
index 0000000000..ce891b5a22
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T16114.hs
@@ -0,0 +1,4 @@
+module T16114 where
+
+data T a
+instance Eq a => Eq a => Eq (T a) where (==) = undefined
diff --git a/testsuite/tests/rename/should_fail/T16114.stderr b/testsuite/tests/rename/should_fail/T16114.stderr
new file mode 100644
index 0000000000..aec0e3e3e0
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T16114.stderr
@@ -0,0 +1,6 @@
+
+T16114.hs:4:10: error:
+    Illegal class instance: ‘Eq a => Eq a => Eq (T a)’
+      Class instances must be of the form
+        context => C ty_1 ... ty_n
+      where ‘C’ is a class
diff --git a/testsuite/tests/rename/should_fail/T5951.stderr b/testsuite/tests/rename/should_fail/T5951.stderr
index 8fda353b33..b325493f35 100644
--- a/testsuite/tests/rename/should_fail/T5951.stderr
+++ b/testsuite/tests/rename/should_fail/T5951.stderr
@@ -1,15 +1,6 @@
 
 T5951.hs:8:8: error:
-    • Expecting one more argument to ‘A’
-      Expected a constraint, but ‘A’ has kind ‘* -> Constraint’
-    • In the instance declaration for ‘B => C’
-
-T5951.hs:9:8: error:
-    • Expecting one more argument to ‘B’
-      Expected a constraint, but ‘B’ has kind ‘* -> Constraint’
-    • In the instance declaration for ‘B => C’
-
-T5951.hs:10:8: error:
-    • Expecting one more argument to ‘C’
-      Expected a constraint, but ‘C’ has kind ‘* -> Constraint’
-    • In the instance declaration for ‘B => C’
+    Illegal class instance: ‘A => B => C’
+      Class instances must be of the form
+        context => C ty_1 ... ty_n
+      where ‘C’ is a class
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index 56934266d2..d5a5ec58e9 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -143,5 +143,5 @@ test('T15611a', normal, compile_fail, [''])
 test('T15611b', normal, ghci_script, ['T15611b.script'])
 test('T15828', normal, compile_fail, [''])
 test('T16002', normal, compile_fail, [''])
-
+test('T16114', normal, compile_fail, [''])
 test('ExplicitForAllRules2', normal, compile_fail, [''])