[commit: ghc] wip/T16191: Fix #16114 by adding a validity check to rnClsInstDecl (83a2206)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T16191
Link       : http://ghc.haskell.org/trac/ghc/changeset/83a22066fbe136e4a984e8c90c1d3fd72b6ec4b9/ghc

>---------------------------------------------------------------

commit 83a22066fbe136e4a984e8c90c1d3fd72b6ec4b9
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Tue Jan 15 08:08:43 2019 -0500

    Fix #16114 by adding a validity check to rnClsInstDecl


>---------------------------------------------------------------

83a22066fbe136e4a984e8c90c1d3fd72b6ec4b9
 compiler/rename/RnSource.hs                      | 26 ++++++++++++++++++------
 compiler/rename/RnTypes.hs                       |  7 -------
 testsuite/tests/rename/should_fail/T16114.hs     |  4 ++++
 testsuite/tests/rename/should_fail/T16114.stderr |  6 ++++++
 testsuite/tests/rename/should_fail/T5951.stderr  | 17 ++++------------
 testsuite/tests/rename/should_fail/all.T         |  2 +-
 6 files changed, 35 insertions(+), 27 deletions(-)

diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index ca35e94..e5fe3a3 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 f66c1bd..3703f1a 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 0000000..ce891b5
--- /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 0000000..aec0e3e
--- /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 8fda353..b325493 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 5693426..d5a5ec5 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, [''])