diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 5784b9ecdb553cb054bef3d24201853d233744c8..e4f74d6b735b2b05eedf72f5018e1f2a97471a17 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 1d47185f022c928724264bc9b51694187bd5d070..6e64d73d3458ded93d7b4689d3c26bc77e8ecd78 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 16897c26814a6f9a4e1ea6300e037734c4f39c3b..516c43c14a1ebc3fb6433180a4077c93faef6eae 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 0000000000000000000000000000000000000000..d68e706b1682509df8f7ec4b93cd19de73abef10
--- /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 0000000000000000000000000000000000000000..26ce914c3dbc0dd76322839930820c51f0dcd28e
--- /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 0000000000000000000000000000000000000000..4cd4f282e48068e3aae29a6a7a0af2c865b7181c
--- /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 0000000000000000000000000000000000000000..b76cc11e2a7d6e602751da9e98cdff86e5332a05
--- /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 182dc421fbc2c981fd621c569455dea5b669e59b..db0db47ca9ed32f3adc4df678553a2d71c6d145a 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'])