Fix #16114 by adding a validity check to rnClsInstDecl

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

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

testsuite/tests/rename/should_fail/T16114.hs

+module T16114 where
+
+data T a
+instance Eq a => Eq a => Eq (T a) where (==) = undefined

testsuite/tests/rename/should_fail/T16114.stderr

+
+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

testsuite/tests/rename/should_fail/T5951.stderr

 
 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

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, [''])