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

@@ -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 ..."

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

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

testsuite/tests/rename/should_fail/T14907a.hs

+module T14907a where
+
+class (Bool, a, b)

testsuite/tests/rename/should_fail/T14907a.stderr

+
+T14907a.hs:3:8: error:
+    Unexpected type ‘Bool’
+    In the class declaration for ‘(,,)’
+    A class declaration should have form
+      class (,,) a b c where ...

testsuite/tests/rename/should_fail/T14907b.hs

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

testsuite/tests/rename/should_fail/T14907b.stderr

+
+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: (,,)

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