[commit: ghc] ghc-8.6: Don't show constraint tuples in errors (#14907) (87266ea)

git at git.haskell.org git at git.haskell.org
Sat Oct 13 17:17:30 UTC 2018


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

On branch  : ghc-8.6
Link       : http://ghc.haskell.org/trac/ghc/changeset/87266ea717de2df11d7b491bf3c525b7c1a1a47a/ghc

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

commit 87266ea717de2df11d7b491bf3c525b7c1a1a47a
Author: Alec Theriault <alec.theriault at gmail.com>
Date:   Tue Sep 25 11:58:12 2018 +0200

    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
    
    (cherry picked from commit 9bfbc4e16d511678cffa9f7f76b369c8cfca7a66)


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

87266ea717de2df11d7b491bf3c525b7c1a1a47a
 compiler/parser/RdrHsSyn.hs                       | 22 +++++++++++++++++++---
 compiler/prelude/TysWiredIn.hs                    | 14 ++++++++++++++
 compiler/rename/RnEnv.hs                          |  4 ++--
 testsuite/tests/rename/should_fail/T14907a.hs     |  3 +++
 testsuite/tests/rename/should_fail/T14907a.stderr |  6 ++++++
 testsuite/tests/rename/should_fail/T14907b.hs     |  7 +++++++
 testsuite/tests/rename/should_fail/T14907b.stderr |  6 ++++++
 testsuite/tests/rename/should_fail/all.T          |  2 ++
 8 files changed, 59 insertions(+), 5 deletions(-)

diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 1ffde22..572636b 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,
@@ -92,7 +93,8 @@ import Lexeme           ( isLexCon )
 import Type             ( TyThing(..) )
 import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                           nilDataConName, nilDataConKey,
-                          listTyConName, listTyConKey )
+                          listTyConName, listTyConKey,
+                          cTupleTyConNameArity_maybe  )
 import ForeignCall
 import PrelNames        ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
 import SrcLoc
@@ -766,6 +768,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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -810,12 +819,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 b96581e..c2e2a37 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
@@ -159,6 +160,8 @@ import BooleanFormula   ( mkAnd )
 
 import qualified Data.ByteString.Char8 as BS
 
+import Data.List        ( elemIndex )
+
 alpha_tyvar :: [TyVar]
 alpha_tyvar = [alphaTyVar]
 
@@ -765,6 +768,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 16897c2..516c43c 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 0000000..d68e706
--- /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 0000000..26ce914
--- /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 0000000..4cd4f28
--- /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 0000000..b76cc11
--- /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 413b24f..ab16ac3 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -130,4 +130,6 @@ 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, [''])



More information about the ghc-commits mailing list