Add TcRnIllegalFieldPunning to TcRnMessage

5 files changed, 30 insertions, 10 deletions

diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 4fc6093f3e..9129a46a8a 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -782,7 +782,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                               , hfbPun      = pun }))
       = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
            ; arg' <- if pun
-                     then do { checkErr pun_ok (badPun (L loc lbl))
+                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L loc lbl))
                                -- Discard any module qualifier (#11662)
                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
                              ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) }
@@ -888,7 +888,7 @@ rnHsRecUpdFields flds
                       -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
                       lookupRecFieldOcc_update dup_fields_ok lbl
            ; arg' <- if pun
-                     then do { checkErr pun_ok (badPun (L loc lbl))
+                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L loc lbl))
                                -- Discard any module qualifier (#11662)
                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
                              ; return (L (noAnnSrcSpan loc) (HsVar noExtField
@@ -935,11 +935,6 @@ badDotDotCon con
     vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)
          , nest 2 (text "The constructor has no labelled fields") ]
 
-badPun :: Located RdrName -> TcRnMessage
-badPun fld = TcRnUnknownMessage $ mkPlainError noHints $
-  vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
-        text "Use NamedFieldPuns to permit this"]
-
 dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage
 dupFieldErr ctxt dups
   = TcRnUnknownMessage $ mkPlainError noHints $
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 29d36eda3c..9f5445e1ac 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -19,6 +19,7 @@ import GHC.Driver.Flags
 import GHC.Hs
 import GHC.Utils.Outputable
 import GHC.Unit.State (pprWithUnitState, UnitState)
+import qualified GHC.LanguageExtensions as LangExt
 
 
 instance Diagnostic TcRnMessage where
@@ -73,6 +74,8 @@ instance Diagnostic TcRnMessage where
               2 (text "Pattern synonym declarations are only valid at top level")
     TcRnEmptyRecordUpdate
       -> mkSimpleDecorated $ text "Empty record update"
+    TcRnIllegalFieldPunning fld
+      -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld)
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -106,6 +109,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnEmptyRecordUpdate
       -> ErrorWithoutFlag
+    TcRnIllegalFieldPunning{}
+      -> ErrorWithoutFlag
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -139,6 +144,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnEmptyRecordUpdate{}
       -> noHints
+    TcRnIllegalFieldPunning{}
+      -> [SuggestExtension LangExt.RecordPuns]
 
 messageWithInfoDiagnosticMessage :: UnitState
                                  -> ErrInfo
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 6e96256db2..2ac17b3399 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -237,6 +237,20 @@ data TcRnMessage where
   -}
   TcRnEmptyRecordUpdate :: TcRnMessage
 
+  {-| TcRnIllegalFieldPunning is an error that occurs whenever
+      field punning is used without the 'NamedFieldPuns' extension enabled.
+
+      Examples(s):
+
+      data Foo = Foo { a :: Int }
+
+      foo :: Foo -> Int
+      foo Foo{a} = a  -- Not ok, punning used without extension.
+
+     Test cases: parser/should_fail/RecordDotSyntaxFail12
+  -}
+  TcRnIllegalFieldPunning :: !(Located RdrName) -> TcRnMessage
+
 
 -- | Where a shadowed name comes from
 data ShadowedNameProvenance
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index e8558b854f..e6e1663fde 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -24,6 +24,10 @@ instance Outputable GhcHint where
       -> case ext of
           LangExt.NegativeLiterals
             -> text "If you are trying to write a large negative literal, use NegativeLiterals"
+          -- RecordPuns is now effectively 'NamedFieldPuns', so we have to pretty-print the
+          -- hint to yield the correct suggestion in terms of extension to enable.
+          LangExt.RecordPuns
+            -> text "Perhaps you intended to use NamedFieldPuns"
           _ -> text "Perhaps you intended to use" <+> ppr ext
     SuggestMissingDo
       -> text "Possibly caused by a missing 'do'?"
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr
index f1101379ce..63cdbea4b4 100644
--- a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr
@@ -1,15 +1,15 @@
 
 RecordDotSyntaxFail12.hs:124:25: error:
     Illegal use of punning for field ‘quux’
-    Use NamedFieldPuns to permit this
+    Suggested fix: Perhaps you intended to use NamedFieldPuns
 
 RecordDotSyntaxFail12.hs:124:46: error:
     Illegal use of punning for field ‘baz’
-    Use NamedFieldPuns to permit this
+    Suggested fix: Perhaps you intended to use NamedFieldPuns
 
 RecordDotSyntaxFail12.hs:124:65: error:
     Illegal use of punning for field ‘bar’
-    Use NamedFieldPuns to permit this
+    Suggested fix: Perhaps you intended to use NamedFieldPuns
 
 RecordDotSyntaxFail12.hs:125:11: error:
     For this to work enable NamedFieldPuns.