EPA: DotFieldOcc does not have exact print annotations

For the code

    {-# LANGUAGE OverloadedRecordUpdate #-}

    operatorUpdate f = f{(+) = 1}

There are no exact print annotations for the parens around the +
symbol, nor does normal ppr print them.

This MR fixes that.

Closes #21805

(cherry picked from commit 792ef44d455c6e987f342fb61515464322a9fa77)

8 files changed, 34 insertions, 8 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index a4960ca555..8af8858511 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -2063,7 +2063,7 @@ type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr
 type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd  (GhcPass pr))))] = SrcSpanAnnL
 
 type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns
-type instance Anno (FieldLabelString) = SrcAnn NoEpAnns
+type instance Anno (FieldLabelString) = SrcSpanAnnN
 type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns
 
 instance (Anno a ~ SrcSpanAnn' (EpAnn an))
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 92afef026b..5a54c029c3 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2549,7 +2549,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
     recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =
         -- The idea here is to convert the label to a singleton [FastString].
         let f = occNameFS . rdrNameOcc $ rdr
-            fl = DotFieldOcc noAnn (L (l2l loc) f) -- AZ: what about the ann?
+            fl = DotFieldOcc noAnn (L loc f)
             lf = locA loc
         in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns
         where
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 69cb0b6dd0..b281440f16 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -37,6 +37,7 @@ import GHC.Core.DataCon (FieldLabelString)
 import GHC.Types.Name
 import GHC.Types.Basic
 import GHC.Types.Fixity
+import GHC.Types.Name.Reader
 import GHC.Types.SourceText
 import GHC.Types.SrcLoc
 import GHC.Unit.Module (ModuleName)
@@ -159,8 +160,20 @@ pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString
 pprFieldLabelStrings (FieldLabelStrings flds) =
     hcat (punctuate dot (map (ppr . unXRec @p) flds))
 
-instance Outputable(XRec p FieldLabelString) => Outputable (DotFieldOcc p) where
-  ppr (DotFieldOcc _ s) = ppr s
+pprPrefixFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString))
+                           => FieldLabelStrings p -> SDoc
+pprPrefixFieldLabelStrings (FieldLabelStrings flds) =
+    hcat (punctuate dot (map (pprPrefixFieldLabelString . unXRec @p) flds))
+
+pprPrefixFieldLabelString :: forall p. UnXRec p => DotFieldOcc p -> SDoc
+pprPrefixFieldLabelString (DotFieldOcc _ s) = (pprPrefixFastString . unXRec @p) s
+pprPrefixFieldLabelString XDotFieldOcc{} = text "XDotFieldOcc"
+
+pprPrefixFastString :: FastString -> SDoc
+pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs)
+
+instance UnXRec p => Outputable (DotFieldOcc p) where
+  ppr (DotFieldOcc _ s) = (pprPrefixFastString . unXRec @p) s
   ppr XDotFieldOcc{} = text "XDotFieldOcc"
 
 -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 2c4195eeb1..6bd68b8e76 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -754,3 +754,8 @@ Test20297:
 Test20846:
 	$(CHECK_PPR)   $(LIBDIR) Test20846.hs
 	$(CHECK_EXACT) $(LIBDIR) Test20846.hs
+
+.PHONY: Test21805
+Test21805:
+	$(CHECK_PPR)   $(LIBDIR) Test21805.hs
+	$(CHECK_EXACT) $(LIBDIR) Test21805.hs
diff --git a/testsuite/tests/printer/Test21805.hs b/testsuite/tests/printer/Test21805.hs
new file mode 100644
index 0000000000..443a6bee87
--- /dev/null
+++ b/testsuite/tests/printer/Test21805.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE OverloadedRecordUpdate #-}
+
+operatorUpdate f = f{(+) = 1}
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 4562acc8e5..d88fa09e99 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -177,3 +177,4 @@ test('Test20247', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20247'])
 test('Test20258', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20258'])
 test('Test20297', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20297'])
 test('Test20846', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20846'])
+test('Test21805', [ignore_stderr, req_ppr_deps], makefile_test, ['Test21805'])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index c73a1f4920..37db197f31 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -30,8 +30,9 @@ import GHC.Data.FastString
 import GHC.Types.Basic hiding (EP)
 import GHC.Types.Fixity
 import GHC.Types.ForeignCall
-import GHC.Types.SourceText
+import GHC.Types.Name.Reader
 import GHC.Types.PkgQual
+import GHC.Types.SourceText
 import GHC.Types.Var
 import GHC.Utils.Outputable hiding ( (<>) )
 import GHC.Unit.Module.Warnings
@@ -2291,9 +2292,11 @@ instance ExactPrint (FieldLabelStrings GhcPs) where
 instance ExactPrint (DotFieldOcc GhcPs) where
   getAnnotationEntry (DotFieldOcc an _) = fromAnn an
 
-  exact (DotFieldOcc an fs) = do
+  exact (DotFieldOcc an (L loc fs)) = do
     markAnnKwM an afDot  AnnDot
-    markAnnotated fs
+    -- The field name has a SrcSpanAnnN, print it as a
+    -- LocatedN RdrName
+    markAnnotated (L loc (mkVarUnqual fs))
 
 -- ---------------------------------------------------------------------
 
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 134661ddd7..6c387b5cbc 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -198,7 +198,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
  -- "../../testsuite/tests/printer/PprSemis.hs" Nothing
  -- "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing
  -- "../../testsuite/tests/parser/should_compile/DumpSemis.hs" Nothing
- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
+ -- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
+ "../../testsuite/tests/printer/Test21805.hs" Nothing
 
 -- cloneT does not need a test, function can be retired