From 9bfbc4e16d511678cffa9f7f76b369c8cfca7a66 Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Tue, 25 Sep 2018 11:58:12 +0200
Subject: [PATCH] Don't show constraint tuples in errors (#14907)
Summary:
This means that 'GHC.Classes.(%,%)' is no longer mentioned in
error messages for things like
class (a,b,c) -- outside of 'GHC.Classes'
class (a,Bool)
Test Plan: make TEST=T14907a && make TEST=T14907b
Reviewers: RyanGlScott, bgamari
Reviewed By: RyanGlScott
Subscribers: rwbarton, carter
GHC Trac Issues: #14907
Differential Revision: https://phabricator.haskell.org/D5172
---
compiler/parser/RdrHsSyn.hs | 22 ++++++++++++++++---
compiler/prelude/TysWiredIn.hs | 14 ++++++++++++
compiler/rename/RnEnv.hs | 4 ++--
testsuite/tests/rename/should_fail/T14907a.hs | 3 +++
.../tests/rename/should_fail/T14907a.stderr | 6 +++++
testsuite/tests/rename/should_fail/T14907b.hs | 7 ++++++
.../tests/rename/should_fail/T14907b.stderr | 6 +++++
testsuite/tests/rename/should_fail/all.T | 2 ++
8 files changed, 59 insertions(+), 5 deletions(-)
create mode 100644 testsuite/tests/rename/should_fail/T14907a.hs
create mode 100644 testsuite/tests/rename/should_fail/T14907a.stderr
create mode 100644 testsuite/tests/rename/should_fail/T14907b.hs
create mode 100644 testsuite/tests/rename/should_fail/T14907b.stderr
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 5784b9ecdb5..e4f74d6b735 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -25,6 +25,7 @@ module RdrHsSyn (
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
+ filterCTuple,
cvBindGroup,
cvBindsAndSigs,
@@ -91,7 +92,8 @@ import Lexeme ( isLexCon )
import Type ( TyThing(..) )
import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon,
nilDataConName, nilDataConKey,
- listTyConName, listTyConKey, eqTyCon_RDR )
+ listTyConName, listTyConKey, eqTyCon_RDR,
+ tupleTyConName, cTupleTyConNameArity_maybe )
import ForeignCall
import PrelNames ( forall_tv_RDR, allNameStrings )
import SrcLoc
@@ -765,6 +767,13 @@ data_con_ty_con dc
| otherwise -- See Note [setRdrNameSpace for wired-in names]
= Unqual (setOccNameSpace tcClsName (getOccName dc))
+-- | Replaces constraint tuple names with corresponding boxed ones.
+filterCTuple :: RdrName -> RdrName
+filterCTuple (Exact n)
+ | Just arity <- cTupleTyConNameArity_maybe n
+ = Exact $ tupleTyConName BoxedTuple arity
+filterCTuple rdr = rdr
+
{- Note [setRdrNameSpace for wired-in names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -809,12 +818,19 @@ checkTyVars pp_what equals_or_where tc tparms
chk t@(L loc _)
= Left (loc,
vcat [ text "Unexpected type" <+> quotes (ppr t)
- , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
+ , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes tc'
, vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form"))
- , nest 2 (pp_what <+> ppr tc
+ , nest 2 (pp_what <+> tc'
<+> hsep (map text (takeList tparms allNameStrings))
<+> equals_or_where) ] ])
+ -- Avoid printing a constraint tuple in the error message. Print
+ -- a plain old tuple instead (since that's what the user probably
+ -- wrote). See #14907
+ tc' = ppr $ fmap filterCTuple tc
+
+
+
whereDots, equalsDots :: SDoc
-- Second argument to checkTyVars
whereDots = text "where ..."
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 1d47185f022..6e64d73d345 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -80,6 +80,7 @@ module TysWiredIn (
-- ** Constraint tuples
cTupleTyConName, cTupleTyConNames, isCTupleTyConName,
+ cTupleTyConNameArity_maybe,
cTupleDataConName, cTupleDataConNames,
-- * Any
@@ -160,6 +161,8 @@ import BooleanFormula ( mkAnd )
import qualified Data.ByteString.Char8 as BS
+import Data.List ( elemIndex )
+
alpha_tyvar :: [TyVar]
alpha_tyvar = [alphaTyVar]
@@ -777,6 +780,17 @@ isCTupleTyConName n
nameModule n == gHC_CLASSES
&& n `elemNameSet` cTupleTyConNameSet
+-- | If the given name is that of a constraint tuple, return its arity.
+-- Note that this is inefficient.
+cTupleTyConNameArity_maybe :: Name -> Maybe Arity
+cTupleTyConNameArity_maybe n
+ | not (isCTupleTyConName n) = Nothing
+ | otherwise = fmap adjustArity (n `elemIndex` cTupleTyConNames)
+ where
+ -- Since `cTupleTyConNames` jumps straight from the `0` to the `2`
+ -- case, we have to adjust accordingly our calculated arity.
+ adjustArity a = if a > 0 then a + 1 else a
+
cTupleDataConName :: Arity -> Name
cTupleDataConName arity
= mkExternalName (mkCTupleDataConUnique arity) gHC_CLASSES
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 16897c26814..516c43c14a1 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -53,7 +53,7 @@ import RdrName
import HscTypes
import TcEnv
import TcRnMonad
-import RdrHsSyn ( setRdrNameSpace )
+import RdrHsSyn ( filterCTuple, setRdrNameSpace )
import TysWiredIn
import Name
import NameSet
@@ -1653,4 +1653,4 @@ badOrigBinding name
--
-- (See Trac #13968.)
where
- occ = rdrNameOcc name
+ occ = rdrNameOcc $ filterCTuple name
diff --git a/testsuite/tests/rename/should_fail/T14907a.hs b/testsuite/tests/rename/should_fail/T14907a.hs
new file mode 100644
index 00000000000..d68e706b168
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T14907a.hs
@@ -0,0 +1,3 @@
+module T14907a where
+
+class (Bool, a, b)
diff --git a/testsuite/tests/rename/should_fail/T14907a.stderr b/testsuite/tests/rename/should_fail/T14907a.stderr
new file mode 100644
index 00000000000..26ce914c3db
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T14907a.stderr
@@ -0,0 +1,6 @@
+
+T14907a.hs:3:8: error:
+ Unexpected type ‘Bool’
+ In the class declaration for ‘(,,)’
+ A class declaration should have form
+ class (,,) a b c where ...
diff --git a/testsuite/tests/rename/should_fail/T14907b.hs b/testsuite/tests/rename/should_fail/T14907b.hs
new file mode 100644
index 00000000000..4cd4f282e48
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T14907b.hs
@@ -0,0 +1,7 @@
+module T14907b where
+
+-- This is effectively trying to redefine the constraint tuples already
+-- defined in 'GHC.Classes'.
+class ()
+class (a,b)
+class (a,b,c)
diff --git a/testsuite/tests/rename/should_fail/T14907b.stderr b/testsuite/tests/rename/should_fail/T14907b.stderr
new file mode 100644
index 00000000000..b76cc11e2a7
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T14907b.stderr
@@ -0,0 +1,6 @@
+
+T14907b.hs:5:1: error: Illegal binding of built-in syntax: ()
+
+T14907b.hs:6:1: error: Illegal binding of built-in syntax: (,)
+
+T14907b.hs:7:1: error: Illegal binding of built-in syntax: (,,)
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index 182dc421fbc..db0db47ca9e 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -131,6 +131,8 @@ test('T13947', normal, compile_fail, [''])
test('T13847', normal, multimod_compile_fail, ['T13847','-v0'])
test('T14307', normal, compile_fail, [''])
test('T14591', normal, compile_fail, [''])
+test('T14907a', normal, compile_fail, [''])
+test('T14907b', normal, compile_fail, [''])
test('T15214', normal, compile_fail, [''])
test('T15539', normal, compile_fail, [''])
test('T15487', normal, multimod_compile_fail, ['T15487','-v0'])
--
GitLab