Rework GHC Exactprint for Record Dot Syntaxwip/az/exactprint-stack-types

Currently WIP, compiles and tests run.

Added roundtrip printer tests too

Updates haddock submodule

24 files changed, 522 insertions, 104 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 0bd19a4cc5..0d612cda13 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -324,13 +324,13 @@ type instance XRecordUpd     GhcPs = ApiAnn
 type instance XRecordUpd     GhcRn = NoExtField
 type instance XRecordUpd     GhcTc = RecordUpdTc
 
-type instance XGetField     GhcPs = NoExtField
+type instance XGetField     GhcPs = ApiAnnCO
 type instance XGetField     GhcRn = NoExtField
 type instance XGetField     GhcTc = Void
 -- HsGetField is eliminated by the renamer. See [Handling overloaded
 -- and rebindable constructs].
 
-type instance XProjection     GhcPs = NoExtField
+type instance XProjection     GhcPs = ApiAnn' AnnProjection
 type instance XProjection     GhcRn = NoExtField
 type instance XProjection     GhcTc = Void
 -- HsProjection is eliminated by the renamer. See [Handling overloaded
@@ -390,11 +390,25 @@ data AnnsLet
       alIn :: AnnAnchor
       } deriving Data
 
+data AnnFieldLabel
+  = AnnFieldLabel {
+      afDot :: Maybe AnnAnchor
+      } deriving Data
+
+data AnnProjection
+  = AnnProjection {
+      apOpen  :: AnnAnchor, -- ^ '('
+      apClose :: AnnAnchor  -- ^ ')'
+      } deriving Data
+
 -- ---------------------------------------------------------------------
 
 type instance XSCC           (GhcPass _) = ApiAnn' AnnPragma
 type instance XXPragE        (GhcPass _) = NoExtCon
 
+type instance XCHsFieldLabel (GhcPass _) = ApiAnn' AnnFieldLabel
+type instance XXHsFieldLabel (GhcPass _) = NoExtCon
+
 type instance XPresent         (GhcPass _) = ApiAnn
 
 type instance XMissing         GhcPs = ApiAnn' AnnAnchor
@@ -586,7 +600,7 @@ ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds })
 ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field })
   = ppr fexp <> dot <> ppr field
 
-ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (punctuate dot (map ppr flds)))
+ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr flds))))
 
 ppr_expr (ExprWithTySig _ expr sig)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 39bcd7f41f..68b55196ca 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -274,6 +274,14 @@ deriving instance Data (RoleAnnotDecl GhcTc)
 -- ---------------------------------------------------------------------
 -- Data derivations from GHC.Hs.Expr -----------------------------------
 
+deriving instance Data (FieldLabelStrings GhcPs)
+deriving instance Data (FieldLabelStrings GhcRn)
+deriving instance Data (FieldLabelStrings GhcTc)
+
+deriving instance Data (HsFieldLabel GhcPs)
+deriving instance Data (HsFieldLabel GhcRn)
+deriving instance Data (HsFieldLabel GhcTc)
+
 -- deriving instance (DataIdLR p p) => Data (HsPragE p)
 deriving instance Data (HsPragE GhcPs)
 deriving instance Data (HsPragE GhcRn)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 0e1c8f4a40..4409756958 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -973,6 +973,9 @@ pprHsForAll tele cxt
               => SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc
     pp_forall separator qtvs
       | null qtvs = whenPprDebug (forAllLit <> separator)
+  -- Note: to fix the PprRecordDotSyntax1 ppr roundtrip test, the <>
+  -- below needs to be <+>. But it means 94 other test results need to
+  -- be updated to match.
       | otherwise = forAllLit <+> interppSP qtvs <> separator
 
 pprLHsContext :: (OutputableBndrId p)
@@ -999,9 +1002,10 @@ pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
     ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
                                  cd_fld_doc = doc }))
         = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
-    ppr_fld (L _ (XConDeclField x)) = ppr x
-    ppr_names [n] = ppr n
-    ppr_names ns = sep (punctuate comma (map ppr ns))
+
+    ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc
+    ppr_names [n] = pprPrefixOcc n
+    ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))
 
 {-
 Note [Printing KindedTyVars]
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 7f44603b92..0c3687e657 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2756,7 +2756,7 @@ fexp    :: { ECP }
                                         acsA (\cs -> sLL $1 (reLoc $>) $ HsStatic (ApiAnn (glR $1) [mj AnnStatic $1] cs) $2) }
 
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
-        -- AZ: check, this whole production is new
+        -- AZ: check, this whole production is new. And add round-trip tests
         | fexp TIGHT_INFIX_PROJ field
             {% runPV (unECP $1) >>= \ $1 ->
                -- Suppose lhs is an application term e.g. 'f a'
@@ -2764,12 +2764,13 @@ fexp    :: { ECP }
                -- (a.b)' rather than '(f a).b.'. However, if lhs
                -- is a projection 'r.a' (say) then we want the
                -- parse '(r.a).b'.
-               fmap ecpFromExp $ ams (case $1 of
-                   L _ (HsApp _ f arg) | not $ isGetField f ->
-                     let l = comb2 arg $3 in
-                     L (getLoc f `combineSrcSpans` l)
-                       (HsApp noExtField f (mkRdrGetField l arg $3))
-                   _ -> mkRdrGetField (comb2 $1 $>) $1 $3) [mj AnnDot $2] }
+               fmap ecpFromExp $ acsa (\cs ->
+                let fl = sLL $2 $> (HsFieldLabel ((ApiAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) noCom)) $3) in
+                 (case $1 of
+                   L l (HsApp an f arg) | not $ isGetField f ->
+                     L (noAnnSrcSpan $ comb2 (reLoc $1) $>)
+                       (HsApp an f (mkRdrGetField l arg fl (ApiAnn (glAR $1) NoApiAnns cs)))
+                   _ -> mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (ApiAnn (glAR $1) NoApiAnns cs))) }
 
         | aexp                       { $1 }
 
@@ -2890,10 +2891,8 @@ aexp2   :: { ECP }
 
         -- This case is only possible when 'OverloadedRecordDotBit' is enabled.
         | '(' projection ')'            { ECP $
-                                            let (loc, (anns, fIELDS)) = $2
-                                                span = combineSrcSpans (combineSrcSpans (getLoc $1) loc) (getLoc $3)
-                                                expr = mkRdrProjection span (reverse fIELDS)
-                                            in amms (ecpFromExp' expr) ([mop $1] ++ reverse anns ++ [mcp $3])
+                                            acsA (\cs -> sLL $1 $> $ mkRdrProjection (reverse (unLoc $2)) (ApiAnn (glR $1) (AnnProjection (glAA $1) (glAA $3)) cs))
+                                            >>= ecpFromExp'
                                         }
 
         | '(#' texp '#)'                { ECP $
@@ -2940,13 +2939,12 @@ aexp2   :: { ECP }
                                       acsA (\cs -> sLL $1 $> $ HsCmdArrForm (ApiAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix
                                                            Nothing (reverse $3)) }
 
-projection :: { (SrcSpan, ([AddAnn], [Located FastString])) }
+projection :: { Located [Located (HsFieldLabel GhcPs)] }
 projection
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer
         : projection TIGHT_INFIX_PROJ field
-             { let (loc, (anns, fs)) = $1 in
-               (combineSrcSpans (combineSrcSpans loc (gl $2)) (gl $3), (mj AnnDot $2 : anns, $3 : fs)) }
-        | PREFIX_PROJ field { (comb2 $1 $2, ([mj AnnDot $1], [$2])) }
+                             {% acs (\cs -> sLL $1 $> ((sLL $2 $> $ HsFieldLabel (ApiAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) : unLoc $1)) }
+        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 $>  [sLL $1 $> $ HsFieldLabel (ApiAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2]) }
 
 splice_exp :: { LHsExpr GhcPs }
         : splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) }
@@ -3364,8 +3362,7 @@ fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }
         : fbind ',' fbinds1
                  { $1 >>= \ $1 ->
                    $3 >>= \ $3 -> do
-                   let gl' = \case { Left (L l _) -> l;  Right (L l _) -> l } in
-                   h <- addTrailingCommaA (gl' $1) (gl $2)
+                   h <- addTrailingCommaFBind $1 (gl $2)
                    return (case $3 of (flds, dd) -> (h : flds, dd)) }
         | fbind                         { $1 >>= \ $1 ->
                                           return ([$1], Nothing) }
@@ -3384,34 +3381,43 @@ fbind   :: { forall b. DisambECP b => PV (Fbind b) }
                         -- The renamer fills in the final value
 
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
+        -- AZ: need to pull out the let block into a helper
         | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp
                         { do
-                            let top = $1
-                                fields = top : reverse $3
+                            let top = sL1 $1 $ HsFieldLabel noAnn $1
+                                ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3)
+                                lf' = comb2 $2 (L lf ())
+                                fields = top : L lf' (HsFieldLabel (ApiAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) noCom) f) : t
                                 final = last fields
-                                l = comb2 top final
+                                l = comb2 $1 $3
                                 isPun = False
                             $5 <- unECP $5
-                            fmap Right $ mkHsProjUpdatePV (comb2 $1 $5) (L l fields) $5 isPun
+                            fmap Right $ mkHsProjUpdatePV (comb2 $1 (reLoc $5)) (L l fields) $5 isPun
+                                            [mj AnnEqual $4]
                         }
 
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
+        -- AZ: need to pull out the let block into a helper
         | field TIGHT_INFIX_PROJ fieldToUpdate
                         { do
-                            let top = $1
-                                fields = top : reverse $3
+                            let top =  sL1 $1 $ HsFieldLabel noAnn $1
+                                ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3)
+                                lf' = comb2 $2 (L lf ())
+                                fields = top : L lf' (HsFieldLabel (ApiAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) noCom) f) : t
                                 final = last fields
-                                l = comb2 top final
+                                l = comb2 $1 $3
                                 isPun = True
-                            var <- mkHsVarPV (noLoc (mkRdrUnqual . mkVarOcc . unpackFS . unLoc $ final))
-                            fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun
+                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLoc final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . hflLabel . unLoc $ final))
+                            fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []
                         }
 
-fieldToUpdate :: { [Located FastString] }
+fieldToUpdate :: { Located [Located (HsFieldLabel GhcPs)] }
 fieldToUpdate
         -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
-        : fieldToUpdate TIGHT_INFIX_PROJ field { $3 : $1 }
-        | field { [$1] }
+        : fieldToUpdate TIGHT_INFIX_PROJ field   {% getCommentsFor (getLoc $3) >>= \cs ->
+                                                     return (sLL $1 $> ((sLL $2 $> (HsFieldLabel (ApiAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }
+        | field       {% getCommentsFor (getLoc $1) >>= \cs ->
+                        return (sL1 $1 [sL1 $1 (HsFieldLabel (ApiAnn (glR $1) (AnnFieldLabel Nothing) cs) $1)]) }
 
 -----------------------------------------------------------------------------
 -- Implicit Parameter Bindings
@@ -4312,16 +4318,14 @@ parseModule = parseModuleNoHaddock >>= addHaddockToModule
 commentsA :: (Monoid ann) => SrcSpan -> ApiAnnComments -> SrcSpanAnn' (ApiAnn' ann)
 commentsA loc cs = SrcSpanAnn (ApiAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc
 
+-- | Instead of getting the *enclosed* comments, this includes the
+-- *preceding* ones.  It is used at the top level to get comments
+-- between top level declarations.
 commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a)
 commentsPA la@(L l a) = do
   cs <- getPriorCommentsFor (getLocA la)
   return (L (addCommentsToSrcAnn l cs) a)
 
-acsP :: (MonadP m, Monoid t) => (Located a) -> m (LocatedAn t a)
-acsP (L l a) = do
-  cs <- getPriorCommentsFor l
-  return (L (addCommentsToSrcAnn (noAnnSrcSpan l) cs) a)
-
 rs :: SrcSpan -> RealSrcSpan
 rs (RealSrcSpan l _) = l
 rs _ = panic "Parser should only have RealSrcSpan"
@@ -4336,6 +4340,10 @@ listAsAnchor (L l _:_) = spanAsAnchor (locA l)
 
 -- -------------------------------------
 
+addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b)
+addTrailingCommaFBind (Left b)  l = fmap Left  (addTrailingCommaA b l)
+addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)
+
 addTrailingVbarA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)
 addTrailingVbarA  la span = addTrailingAnnA la span AddVbarAnn
 
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 32d92681c6..66d2699b35 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -111,7 +111,7 @@ module GHC.Parser.PostProcess (
 import GHC.Prelude
 import GHC.Hs           -- Lots of it
 import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
-import GHC.Core.DataCon        ( DataCon, dataConTyCon, FieldLabelString )
+import GHC.Core.DataCon        ( DataCon, dataConTyCon )
 import GHC.Core.ConLike        ( ConLike(..) )
 import GHC.Core.Coercion.Axiom ( Role, fsFromRole )
 import GHC.Types.Name.Reader
@@ -138,7 +138,6 @@ import GHC.Data.FastString
 import GHC.Data.Maybe
 import GHC.Data.Bag
 import GHC.Utils.Misc
-import GHC.Parser.Annotation
 import Data.Either
 import Data.List
 import Data.Foldable
@@ -1376,7 +1375,7 @@ ecpFromCmd a = ECP (ecpFromCmd' a)
 
 -- The 'fbinds' parser rule produces values of this type. See Note
 -- [RecordDotSyntax field updates].
-type Fbind b = Either (LHsRecField GhcPs (Located b)) (LHsRecProj GhcPs (Located b))
+type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))
 
 -- | Disambiguate infix operators.
 -- See Note [Ambiguous syntactic categories]
@@ -1416,7 +1415,8 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
   ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)
   -- | Return an expression without ambiguity, or fail in a non-expression context.
   ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)
-  mkHsProjUpdatePV :: SrcSpan -> Located [Located FieldLabelString] -> Located b -> Bool -> PV (LHsRecProj GhcPs (Located b))
+  mkHsProjUpdatePV :: SrcSpan -> Located [Located (HsFieldLabel GhcPs)]
+    -> LocatedA b -> Bool -> [AddApiAnn] -> PV (LHsRecProj GhcPs (LocatedA b))
   -- | Disambiguate "\... -> ..." (lambda)
   mkHsLamPV
     :: SrcSpan -> (ApiAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b)
@@ -1558,7 +1558,7 @@ instance DisambECP (HsCmd GhcPs) where
   type Body (HsCmd GhcPs) = HsCmd
   ecpFromCmd' = return
   ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)
-  mkHsProjUpdatePV l _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l
+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l
   mkHsLamPV l mg = do
     cs <- getCommentsFor l
     return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs))
@@ -1606,7 +1606,7 @@ instance DisambECP (HsCmd GhcPs) where
   mkHsExplicitListPV l xs _ = cmdFail l $
     brackets (fsep (punctuate comma (map ppr xs)))
   mkHsSplicePV (L l sp) = cmdFail l (ppr sp)
-  mkHsRecordPV _ l _ a (fbinds, ddLoc) = do
+  mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do
     let (fs, ps) = partitionEithers fbinds
     if not (null ps)
       then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l
@@ -1636,7 +1636,9 @@ instance DisambECP (HsExpr GhcPs) where
     addError $ PsError (PsErrArrowCmdInExpr c) [] (locA l)
     return (L l (hsHoleExpr noAnn))
   ecpFromExp' = return
-  mkHsProjUpdatePV l fields arg isPun = return $ mkRdrProjUpdate l fields arg isPun
+  mkHsProjUpdatePV l fields arg isPun anns = do
+    cs <- getCommentsFor l
+    return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (ApiAnn (spanAsAnchor l) anns cs)
   mkHsLamPV l mg = do
     cs <- getCommentsFor l
     return $ L (noAnnSrcSpan l) (HsLam NoExtField (mg cs))
@@ -1732,7 +1734,7 @@ instance DisambECP (PatBuilder GhcPs) where
   ecpFromExp' (L l e)    = addFatalError $ PsError (PsErrArrowExprInPat e) [] (locA l)
   mkHsLamPV l _          = addFatalError $ PsError PsErrLambdaInPat [] l
   mkHsLetPV l _ _ _      = addFatalError $ PsError PsErrLetInPat [] l
-  mkHsProjUpdatePV l _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l
+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l
   type InfixOp (PatBuilder GhcPs) = RdrName
   superInfixOp m = m
   mkHsOpAppPV l p1 op p2 = do
@@ -1769,7 +1771,7 @@ instance DisambECP (PatBuilder GhcPs) where
      then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l
      else do
        cs <- getCommentsFor l
-       r <- mkPatRec a (mk_rec_fields fbinds ddLoc) (ApiAnn (spanAsAnchor l) anns cs)
+       r <- mkPatRec a (mk_rec_fields fs ddLoc) (ApiAnn (spanAsAnchor l) anns cs)
        checkRecordSyntax (L (noAnnSrcSpan l) r)
   mkHsNegAppPV l (L lp p) anns = do
     lit <- case p of
@@ -2378,19 +2380,19 @@ mkRecConstrOrUpdate
         -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)
         -> ApiAnn
         -> PV (HsExpr GhcPs)
-mkRecConstrOrUpdate _ (L l (HsVar _ (L _ c))) _lrec (fbinds,dd) anns
+mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns
   | isRdrDataCon c
   = do
       let (fs, ps) = partitionEithers fbinds
       if not (null ps)
-        then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLoc (head ps))
+        then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLocA (head ps))
         else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)
-mkRecConstrOrUpdate overloaded_update exp _ (fs,dd)
+mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns
   | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc
   | otherwise = mkRdrRecordUpd overloaded_update exp fs anns
 
-mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> PV (HsExpr GhcPs)
-mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do
+mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> ApiAnn -> PV (HsExpr GhcPs)
+mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
   -- We do not need to know if OverloadedRecordDot is in effect. We do
   -- however need to know if OverloadedRecordUpdate (passed in
   -- overloaded_on) is in effect because it affects the Left/Right nature
@@ -2400,16 +2402,16 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do
   case overloaded_on of
     False | not $ null ps ->
       -- A '.' was found in an update and OverloadedRecordUpdate isn't on.
-      addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] loc
+      addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] (locA loc)
     False ->
       -- This is just a regular record update.
       return RecordUpd {
-        rupd_ext = noExtField
+        rupd_ext = anns
       , rupd_expr = exp
       , rupd_flds = Left fs' }
     True -> do
       let qualifiedFields =
-            [ L l lbl | L _ (HsRecField (L l lbl) _ _) <- fs'
+            [ L l lbl | L _ (HsRecField _ (L l lbl) _ _) <- fs'
                       , isQual . rdrNameAmbiguousFieldOcc $ lbl
             ]
       if not $ null qualifiedFields
@@ -2417,7 +2419,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do
           addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields))
         else -- This is a RecordDotSyntax update.
           return RecordUpd {
-            rupd_ext = noExtField
+            rupd_ext = anns
            , rupd_expr = exp
            , rupd_flds = Right (toProjUpdates fbinds) }
   where
@@ -2427,17 +2429,19 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do
     -- Convert a top-level field update like {foo=2} or {bar} (punned)
     -- to a projection update.
     recFieldToProjUpdate :: LHsRecField GhcPs  (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs
-    recFieldToProjUpdate (L l (HsRecField (L _ (FieldOcc _ (L loc rdr))) arg pun)) =
+    recFieldToProjUpdate (L l (HsRecField 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
-        in mkRdrProjUpdate l (L loc [L loc f]) (punnedVar f) pun
+            fl = HsFieldLabel noAnn (L lf f) -- AZ: what about the ann?
+            lf = locA loc
+        in mkRdrProjUpdate l (L lf [L lf fl]) (punnedVar f) pun anns
         where
           -- If punning, compute HsVar "f" otherwise just arg. This
           -- has the effect that sentinel HsVar "pun-rhs" is replaced
           -- by HsVar "f" here, before the update is written to a
           -- setField expressions.
           punnedVar :: FastString -> LHsExpr GhcPs
-          punnedVar f  = if not pun then arg else noLoc . HsVar noExtField . noLoc . mkRdrUnqual . mkVarOccFS $ f
+          punnedVar f  = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f
 
 mkRdrRecordCon
   :: LocatedN RdrName -> HsRecordBinds GhcPs -> ApiAnn -> HsExpr GhcPs
@@ -2949,27 +2953,31 @@ isGetField :: LHsExpr GhcPs -> Bool
 isGetField (L _ HsGetField{}) = True
 isGetField _ = False
 
-mkRdrGetField :: SrcSpan -> LHsExpr GhcPs -> Located FieldLabelString -> LHsExpr GhcPs
-mkRdrGetField loc arg field =
+mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (HsFieldLabel GhcPs)
+  -> ApiAnnCO -> LHsExpr GhcPs
+mkRdrGetField loc arg field anns =
   L loc HsGetField {
-      gf_ext = noExtField
+      gf_ext = anns
     , gf_expr = arg
     , gf_field = field
     }
 
-mkRdrProjection :: SrcSpan -> [Located FieldLabelString] -> LHsExpr GhcPs
-mkRdrProjection _ [] = panic "mkRdrProjection: The impossible has happened!"
-mkRdrProjection loc flds =
-  L loc HsProjection {
-      proj_ext = noExtField
+mkRdrProjection :: [Located (HsFieldLabel GhcPs)] -> ApiAnn' AnnProjection -> HsExpr GhcPs
+mkRdrProjection [] _ = panic "mkRdrProjection: The impossible has happened!"
+mkRdrProjection flds anns =
+  HsProjection {
+      proj_ext = anns
     , proj_flds = flds
     }
 
-mkRdrProjUpdate :: SrcSpan -> Located [Located FieldLabelString] -> LHsExpr GhcPs -> Bool -> LHsRecProj GhcPs (LHsExpr GhcPs)
-mkRdrProjUpdate _ (L _ []) _ _ = panic "mkRdrProjUpdate: The impossible has happened!"
-mkRdrProjUpdate loc (L l flds) arg isPun =
+mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (HsFieldLabel GhcPs)]
+                -> LHsExpr GhcPs -> Bool -> ApiAnn
+                -> LHsRecProj GhcPs (LHsExpr GhcPs)
+mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!"
+mkRdrProjUpdate loc (L l flds) arg isPun anns =
   L loc HsRecField {
-      hsRecFieldLbl = L l (FieldLabelStrings flds)
+      hsRecFieldAnn = anns
+    , hsRecFieldLbl = L l (FieldLabelStrings flds)
     , hsRecFieldArg = arg
     , hsRecPun = isPun
   }
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 8b33197b6c..bbf52be2f8 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -312,17 +312,19 @@ rnExpr (NegApp _ e _)
 rnExpr (HsGetField _ e f)
  = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
       ; (e, fv_e) <- rnLExpr e
+      ; let f' = rnHsFieldLabel f
       ; return ( mkExpandedExpr
-                   (HsGetField noExtField e f)
-                   (mkGetField getField e f)
+                   (HsGetField noExtField e f')
+                   (mkGetField getField e (fmap (unLoc . hflLabel) f'))
                , fv_e `plusFV` fv_getField ) }
 
 rnExpr (HsProjection _ fs)
   = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
        ; circ <- lookupOccRn compose_RDR
+       ; let fs' = fmap rnHsFieldLabel fs
        ; return ( mkExpandedExpr
-                    (HsProjection noExtField fs)
-                    (mkProjection getField circ fs)
+                    (HsProjection noExtField fs')
+                    (mkProjection getField circ (map (fmap (unLoc . hflLabel)) fs'))
                 , unitFV circ `plusFV` fv_getField) }
 
 ------------------------------------------
@@ -543,7 +545,6 @@ rnExpr (HsProc x pat body)
 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
         -- HsWrap
 
-
 {- *********************************************************************
 *                                                                      *
         Operator sections
@@ -696,6 +697,19 @@ bindNonRec will automatically do the right thing, giving us:
 See #18151.
 -}
 
+{-
+************************************************************************
+*                                                                      *
+        Field Labels
+*                                                                      *
+************************************************************************
+-}
+
+rnHsFieldLabel :: Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)
+rnHsFieldLabel (L l (HsFieldLabel x label)) = L l (HsFieldLabel x label)
+
+rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
+rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnHsFieldLabel fls)
 
 {-
 ************************************************************************
@@ -2605,8 +2619,9 @@ mkProjection _ _ [] = panic "mkProjection: The impossible happened"
 -- e.g. Suppose an update like foo.bar = 1.
 --      We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1).
 mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)
-mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds)), hsRecFieldArg = arg } ))
+mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds')), hsRecFieldArg = arg } ))
   = let {
+      ; flds = map (fmap (unLoc . hflLabel)) flds'
       ; final = last flds  -- quux
       ; fields = init flds   -- [foo, bar, baz]
       ; getters = \a -> foldl' (mkGet get_field) [a] fields  -- Ordered from deep to shallow.
@@ -2629,6 +2644,9 @@ rnHsUpdProjs us = do
   pure (u, plusFVs fvs)
   where
     rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
-    rnRecUpdProj (L l (HsRecField fs arg pun))
+    rnRecUpdProj (L l (HsRecField _ fs arg pun))
       = do { (arg, fv) <- rnLExpr arg
-           ; return $ (L l (HsRecField { hsRecFieldLbl = fs, hsRecFieldArg = arg, hsRecPun = pun}), fv) }
+           ; return $ (L l (HsRecField { hsRecFieldAnn = noAnn
+                                       , hsRecFieldLbl = fmap rnFieldLabelStrings fs
+                                       , hsRecFieldArg = arg
+                                       , hsRecPun = pun}), fv) }
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index b1dd472d75..4ddb0ee000 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -479,7 +479,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e
 
 exprCtOrigin :: HsExpr GhcRn -> CtOrigin
 exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
-exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin f
+exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ hflLabel f)
 exprCtOrigin (HsUnboundVar {})    = Shouldn'tHappenOrigin "unbound variable"
 exprCtOrigin (HsConLikeOut {})    = panic "exprCtOrigin HsConLikeOut"
 exprCtOrigin (HsRecFld _ f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index a09ff4257c..1009ea72f0 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1039,7 +1039,7 @@ cvtl e = wrapLA (cvt e)
                               ; flds'
                                   <- mapM (cvtFld (mkAmbiguousFieldOcc . noLocA))
                                            flds
-                              ; return $ RecordUpd noExtField e' (Left flds') }
+                              ; return $ RecordUpd noAnn e' (Left flds') }
     cvt (StaticE e)      = fmap (HsStatic noAnn) $ cvtl e
     cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is
                               -- important, because UnboundVarE may contain
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index f109800818..cb84d25489 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -143,26 +143,37 @@ values (see function @mkRdrRecordUpd@ in 'GHC.Parser.PostProcess').
 
 -- | RecordDotSyntax field updates
 
-newtype FieldLabelStrings =
-  FieldLabelStrings [Located FieldLabelString]
-                               deriving (Data)
+newtype FieldLabelStrings p =
+  FieldLabelStrings [Located (HsFieldLabel p)]
 
-instance Outputable FieldLabelStrings where
+instance Outputable (FieldLabelStrings p) where
   ppr (FieldLabelStrings flds) =
     hcat (punctuate dot (map (ppr . unLoc) flds))
 
+instance OutputableBndr (FieldLabelStrings p) where
+  pprInfixOcc = pprFieldLabelStrings
+  pprPrefixOcc = pprFieldLabelStrings
+
+pprFieldLabelStrings :: FieldLabelStrings p -> SDoc
+pprFieldLabelStrings (FieldLabelStrings flds) =
+    hcat (punctuate dot (map (ppr . unLoc) flds))
+
+instance Outputable (HsFieldLabel p) where
+  ppr (HsFieldLabel _ s) = ppr s
+  ppr XHsFieldLabel{} = text "XHsFieldLabel"
+
 -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note
 -- [RecordDotSyntax field updates].
-type RecProj arg = HsRecField' FieldLabelStrings arg
+type RecProj p arg = HsRecField' (FieldLabelStrings p) arg
 
 -- The phantom type parameter @p@ is for symmetry with @LHsRecField p
 -- arg@ in the definition of @data Fbind@ (see GHC.Parser.Process).
-type LHsRecProj p arg = Located (RecProj arg)
+type LHsRecProj p arg = XRec p (RecProj p arg)
 
 -- These two synonyms are used in the definition of syntax @RecordUpd@
 -- below.
-type RecUpdProj p = RecProj (LHsExpr p)
-type LHsRecUpdProj p = Located (RecUpdProj p)
+type RecUpdProj p = RecProj p (LHsExpr p)
+type LHsRecUpdProj p = XRec p (RecUpdProj p)
 
 {-
 ************************************************************************
@@ -483,7 +494,7 @@ data HsExpr p
   | HsGetField {
         gf_ext :: XGetField p
       , gf_expr :: LHsExpr p
-      , gf_field :: Located FieldLabelString
+      , gf_field :: Located (HsFieldLabel p)
       }
 
   -- | Record field selector. e.g. @(.x)@ or @(.x.y)@
@@ -496,7 +507,7 @@ data HsExpr p
 
   | HsProjection {
         proj_ext :: XProjection p
-      , proj_flds :: [Located FieldLabelString]
+      , proj_flds :: [Located (HsFieldLabel p)]
       }
 
   -- | Expression with an explicit type signature. @e :: type@
@@ -611,6 +622,15 @@ type family PendingTcSplice' p
 
 -- ---------------------------------------------------------------------
 
+data HsFieldLabel p
+  = HsFieldLabel
+    { hflExt   :: XCHsFieldLabel p
+    , hflLabel :: Located FieldLabelString
+    }
+  | XHsFieldLabel !(XXHsFieldLabel p)
+
+-- ---------------------------------------------------------------------
+
 -- | A pragma, written as {-# ... #-}, that may appear within an expression.
 data HsPragE p
   = HsPragSCC   (XSCC p)
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 0e2ae9f5da..cd9804b7f9 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -425,6 +425,11 @@ type family XPragE          x
 type family XXExpr          x
 
 -- -------------------------------------
+-- FieldLabel type families
+type family XCHsFieldLabel  x
+type family XXHsFieldLabel  x
+
+-- -------------------------------------
 -- HsPragE type families
 type family XSCC            x
 type family XXPragE         x
diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs
index a525c9679e..8c3309f477 100644
--- a/compiler/Language/Haskell/Syntax/Pat.hs
+++ b/compiler/Language/Haskell/Syntax/Pat.hs
@@ -368,8 +368,8 @@ instance (Outputable arg, Outputable (XRec p (HsRecField p arg)))
         where
           dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))
 
-instance (Outputable p, Outputable arg)
+instance (Outputable p, OutputableBndr p, Outputable arg)
       => Outputable (HsRecField' p arg) where
-  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
+  ppr (HsRecField { hsRecFieldLbl = L _ f, hsRecFieldArg = arg,
                     hsRecPun = pun })
-    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
+    = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg)
diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index a71f356119..8904459da8 100644
--- a/compiler/Language/Haskell/Syntax/Type.hs
+++ b/compiler/Language/Haskell/Syntax/Type.hs
@@ -1270,6 +1270,13 @@ deriving instance (Eq (XCFieldOcc pass), Eq (XXFieldOcc pass)) => Eq (FieldOcc p
 instance Outputable (FieldOcc pass) where
   ppr = ppr . rdrNameFieldOcc
 
+instance OutputableBndr (FieldOcc pass) where
+  pprInfixOcc  = pprInfixOcc . unLoc . rdrNameFieldOcc
+  pprPrefixOcc = pprPrefixOcc . unLoc . rdrNameFieldOcc
+
+instance OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where
+  pprInfixOcc  = pprInfixOcc . unLoc
+  pprPrefixOcc = pprPrefixOcc . unLoc
 
 -- | Ambiguous Field Occurrence
 --
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index e3d9709391..2f3d7fb187 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -520,3 +520,28 @@ ListComprehensions:
 load-main:
 	$(CHECK_PPR)   "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" load-main.hs
 	$(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" load-main.hs
+
+.PHONY: PprRecordDotSyntax1
+PprRecordDotSyntax1:
+	$(CHECK_PPR)   "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax1.hs
+	$(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax1.hs
+
+.PHONY: PprRecordDotSyntax2
+PprRecordDotSyntax2:
+	$(CHECK_PPR)   "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax2.hs
+	$(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax2.hs
+
+.PHONY: PprRecordDotSyntax3
+PprRecordDotSyntax3:
+	$(CHECK_PPR)   "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax3.hs
+	$(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax3.hs
+
+.PHONY: PprRecordDotSyntax4
+PprRecordDotSyntax4:
+	$(CHECK_PPR)   "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax4.hs
+	$(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax4.hs
+
+.PHONY: PprRecordDotSyntaxA
+PprRecordDotSyntaxA:
+	$(CHECK_PPR)   "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntaxA.hs
+	$(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntaxA.hs
diff --git a/testsuite/tests/printer/PprRecordDotSyntax1.hs b/testsuite/tests/printer/PprRecordDotSyntax1.hs
new file mode 100644
index 0000000000..19764deb99
--- /dev/null
+++ b/testsuite/tests/printer/PprRecordDotSyntax1.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-}
+-- For "higher kinded data" test.
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-# LANGUAGE RebindableSyntax #-}
+module PprRecordDotSyntax1 where
+
+import Prelude
+
+-- Choice (C2a).
+
+import Data.Function -- for &
+import Data.Functor.Identity
+
+class HasField x r a | x r -> a where
+  hasField :: r -> (a -> r, a)
+
+getField :: forall x r a . HasField x r a => r -> a
+getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
+
+setField :: forall x r a . HasField x r a => r -> a -> r
+setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
+
+-- 'Foo' has 'foo' field of type 'Bar'
+data Foo = Foo { foo :: Bar } deriving (Show, Eq)
+instance HasField "foo" Foo Bar where
+    hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r)
+
+-- 'Bar' has a 'bar' field of type 'Baz'
+data Bar = Bar { bar :: Baz } deriving (Show, Eq)
+instance HasField "bar" Bar Baz where
+    hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r)
+
+-- 'Baz' has a 'baz' field of type 'Quux'
+data Baz = Baz { baz :: Quux } deriving (Show, Eq)
+instance HasField "baz" Baz Quux where
+    hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r)
+
+-- 'Quux' has a 'quux' field of type 'Int'
+data Quux = Quux { quux :: Int } deriving (Show, Eq)
+instance HasField "quux" Quux Int where
+    hasField r = (\x -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r)
+
+-- 'Corge' has a '&&&' field of type 'Int'
+data Corge = Corge { (&&&) :: Int } deriving (Show, Eq)
+instance HasField "&&&" Corge Int where
+    hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r)
+-- Note : Dot notation is not available for fields with operator
+-- names.
+
+-- 'Grault' has two fields 'f' and 'g' of type 'Foo'.
+data Grault = Grault {f :: Foo, g :: Foo} deriving (Show, Eq)
+instance HasField "f" Grault Foo where
+    hasField r = (\x -> case r of Grault { .. } -> Grault { f = x, .. }, f r)
+instance HasField "g" Grault Foo where
+    hasField r = (\x -> case r of Grault { .. } -> Grault { g = x, .. }, g r)
+
+-- "Higher kinded data"
+-- (see https://reasonablypolymorphic.com/blog/higher-kinded-data/)
+type family H f a where
+  H Identity a = a
+  H f        a = f a
+data P f = P
+  { n :: H f String
+  }
+-- See https://github.com/ndmitchell/record-dot-preprocessor/pull/34.
+instance (a ~ H f String) => HasField "n" (P f) a where
+    hasField r = (\x -> case r of P { .. } -> P { n = x, .. }, n r)
+
+main = do
+  let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
+  let b = Corge{ (&&&) = 12 };
+  let c = Grault {
+        f = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
+      , g = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
+       }
+
+  -- A "selector" is an expression like '(.a)' or '(.a.b)'.
+  putStrLn "-- selectors:"
+  print $ (.foo) a  -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+  print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } }
+  print $ (.foo.bar.baz) a -- Quux { quux = 42 }
+  print $ (.foo.bar.baz.quux) a -- 42
+  print $ ((&&&) b) -- 12
+  -- print $ (b.(&&&)) -- illegal : parse error on input ‘(’
+  print $ getField @"&&&" b -- 12
+
+  -- A "selection" is an expression like 'r.a' or '(f r).a.b'.
+  putStrLn "-- selections:"
+  print $ a.foo.bar.baz.quux -- 42
+  print $ a.foo.bar.baz -- Quux { quux = 42 }
+  print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } }
+  print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+  print $ (const "hello") a.foo  -- f r.x means f (r.x)
+  -- print $ f a .foo  -- f r .x is illegal
+  print $ (const "hello") (id a).foo  -- f (g r).x means f ((g r).x)
+  -- print $ f (g a) .foo -- f (g r) .x is illegal
+  print $ a.foo
+            & (.bar.baz.quux) -- 42
+  print $ (a.foo
+               ).bar.baz.quux -- 42
+  print $ (+) a.foo.bar.baz.quux 1 -- 43
+  print $ (+) (id a).foo.bar.baz.quux 1 -- 43
+  print $ (+) ((id a).foo.bar & (.baz.quux)) 1 -- 43
+
+  -- An "update" is an expression like 'r{ a.b = 12 }'.
+  putStrLn "-- updates:"
+  print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 }
+  print $ (\b -> b{ bar=Baz{ baz=Quux{ quux=1 } } }) a.foo -- Bar { bar = Baz { baz = Quux { quux = 1 } } }
+  let bar = Bar { bar = Baz { baz = Quux { quux = 44 } } }
+  print $ a{ foo.bar = Baz { baz = Quux { quux = 44 } } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 44 } } } }
+  print $ a{ foo.bar.baz = Quux { quux = 45 } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 45 } } } }
+  print $ a{ foo.bar.baz.quux = 46 } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 46 } } } }
+  print $ c{ f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4 } -- Grault { f = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 3 } } } }, g = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 4 } } } } }
+
+  -- A "punned update" is an expression like 'r{ a.b }' (where it is
+  -- understood that 'b' is a variable binding in the environment of
+  -- the field update - enabled only when the extension
+  -- 'NamedFieldPuns' is in effect).
+  putStrLn "-- punned updates:"
+  let quux = 102; baz = Quux { quux }; bar = Baz { baz }; foo = Bar { bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+  print $ a{ foo.bar.baz.quux } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+  print $ a{ foo.bar.baz } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+  print $ a{ foo.bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+  print $ a{ foo } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
+  print $ a -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 42 } } } }
+  print $ c{ f.foo, g.foo.bar.baz.quux = 4 } -- Mix punned and explicit; 102, 4
+  f <- pure a
+  g <- pure a
+  print $ c{ f } -- 42, 1
+  print $ c{ f, g } -- 42, 42
+  print $ c{ f, g.foo.bar.baz.quux = 4 } -- Mix top-level and nested updates; 42, 4
+
+  putStrLn "-- misc:"
+  -- Higher kinded test.
+  let p = P { n = Just "me" } :: P Maybe
+  Just me <- pure p.n
+  putStrLn $ me
diff --git a/testsuite/tests/printer/PprRecordDotSyntax2.hs b/testsuite/tests/printer/PprRecordDotSyntax2.hs
new file mode 100644
index 0000000000..8677914e46
--- /dev/null
+++ b/testsuite/tests/printer/PprRecordDotSyntax2.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE NoRebindableSyntax #-}
+
+module PprRecordDotSyntax2 where
+
+data Foo = Foo { foo :: Bar } deriving (Show, Eq)
+data Bar = Bar { bar :: Baz } deriving (Show, Eq)
+data Baz = Baz { baz :: Quux } deriving (Show, Eq)
+data Quux = Quux { quux :: Int } deriving (Show, Eq)
+
+main = do
+  let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
+
+  -- A "selector" is an expression like '(.a)' or '(.a.b)'.
+  putStrLn "-- selectors:"
+  print $ (.foo) a  -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+  print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } }
+  print $ (.foo.bar.baz) a -- Quux { quux = 42 }
+  print $ (.foo.bar.baz.quux) a -- 42
+
+  -- A "selection" is an expression like 'r.a' or '(f r).a.b'.
+  putStrLn "-- selections:"
+  print $ a.foo.bar.baz.quux -- 42
+  print $ a.foo.bar.baz -- Quux { quux = 42 }
+  print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } }
+  print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+
+  -- An "update" is an expression like 'r{ a.b = 12 }'.
+  --
+  -- We don't support these (in the case Rebindable Syntax is off) yet
+  -- (waiting on HasField support).
+  --
+  -- Regular updates are fine though!
+  print $ a{foo=(foo a){bar = (bar (foo a)){baz = (baz (bar (foo a))){quux = quux (baz (bar (foo a))) + 1}}}}
+  print $ a{foo=(a.foo){bar = (a.foo.bar){baz = (a.foo.bar.baz){quux = a.foo.bar.baz.quux + 1}}}}
diff --git a/testsuite/tests/printer/PprRecordDotSyntax3.hs b/testsuite/tests/printer/PprRecordDotSyntax3.hs
new file mode 100644
index 0000000000..6056af152a
--- /dev/null
+++ b/testsuite/tests/printer/PprRecordDotSyntax3.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module PprRecordDotSyntax3 where
+
+import qualified RecordDotSyntaxA as A
+
+
+main = do
+  print $ id A.n -- Foo {foo = 2}; f M.x means f (M.x)
+  print $ id A.n.foo -- 2; f M.n.x means f (M.n.x)
+
+  let bar = A.Foo {A.foo = 1}
+  print $ bar.foo -- Ok; 1
+  -- print $ bar.A.foo -- parse error on input 'A.foo'
diff --git a/testsuite/tests/printer/PprRecordDotSyntax4.hs b/testsuite/tests/printer/PprRecordDotSyntax4.hs
new file mode 100644
index 0000000000..6dda73d68c
--- /dev/null
+++ b/testsuite/tests/printer/PprRecordDotSyntax4.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module PprRecordDotSyntax4 where
+
+import qualified RecordDotSyntaxA as A
+
+main = do
+  let bar = A.Foo {A.foo = 1}
+  print $ bar{A.foo = 2} -- Qualified labels ok in regular updates.
diff --git a/testsuite/tests/printer/PprRecordDotSyntaxA.hs b/testsuite/tests/printer/PprRecordDotSyntaxA.hs
new file mode 100644
index 0000000000..907d6a23f6
--- /dev/null
+++ b/testsuite/tests/printer/PprRecordDotSyntaxA.hs
@@ -0,0 +1,6 @@
+module RecordDotSyntaxA where
+
+data Foo = Foo { foo :: Int } deriving Show
+
+n :: Foo
+n = Foo {foo = 2}
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index da2fe9ba96..7f8de4e9e5 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -109,3 +109,11 @@ test('BundleExport', ignore_stderr, makefile_test, ['BundleExport'])
 test('AnnotationTuple', ignore_stderr, makefile_test, ['AnnotationTuple'])
 test('ListComprehensions', ignore_stderr, makefile_test, ['ListComprehensions'])
 test('load-main', ignore_stderr, makefile_test, ['load-main'])
+
+# PPR of explicit foralls needs the "." to have an extra space. See note in pprHsForAll
+test('PprRecordDotSyntax1', [ignore_stderr, expect_fail], makefile_test, ['PprRecordDotSyntax1'])
+
+test('PprRecordDotSyntax2', ignore_stderr, makefile_test, ['PprRecordDotSyntax2'])
+test('PprRecordDotSyntax3', ignore_stderr, makefile_test, ['PprRecordDotSyntax3'])
+test('PprRecordDotSyntax4', ignore_stderr, makefile_test, ['PprRecordDotSyntax4'])
+test('PprRecordDotSyntaxA', ignore_stderr, makefile_test, ['PprRecordDotSyntaxA'])
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 9a16d9628d..5fb2716129 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -21,7 +21,8 @@ import ExactPrint
 
 tt :: IO ()
 -- tt = testOneFile "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
-tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
+-- tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
+tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
  -- "../../testsuite/tests/printer/Ppr001.hs"
  -- "../../testsuite/tests/printer/Ppr002.hs"
  -- "../../testsuite/tests/printer/Ppr002a.hs"
@@ -30,7 +31,6 @@ tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/s
  -- "../../testsuite/tests/printer/Ppr005.hs"
  -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs"
  -- "../../testsuite/tests/printer/Ppr006.hs"
- -- "../../testsuite/tests/printer/Ppr006a.hs"
  -- "../../testsuite/tests/printer/Ppr007.hs"
  -- "../../testsuite/tests/printer/Ppr008.hs"
  -- "../../testsuite/tests/hiefile/should_compile/hie008.hs"
@@ -104,7 +104,7 @@ tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/s
  -- "../../testsuite/tests/printer/Test10354.hs"
  -- "../../testsuite/tests/printer/Test10357.hs"
  -- "../../testsuite/tests/printer/Test10399.hs"
- "../../testsuite/tests/printer/Test11018.hs"
+ -- "../../testsuite/tests/printer/Test11018.hs"
  -- "../../testsuite/tests/printer/Test11332.hs"
  -- "../../testsuite/tests/printer/Test16230.hs"
  -- "../../testsuite/tests/printer/Test16236.hs"
@@ -121,6 +121,11 @@ tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/s
  -- "./cases/AddLocalDecl1.hs"
  -- "./cases/LayoutIn1.hs"
  -- "./cases/EmptyWheres.hs"
+ -- "../../testsuite/tests/printer/PprRecordDotSyntax1.hs"
+ -- "../../testsuite/tests/printer/PprRecordDotSyntax2.hs"
+ -- "../../testsuite/tests/printer/PprRecordDotSyntax3.hs"
+ -- "../../testsuite/tests/printer/PprRecordDotSyntax4.hs"
+ "../../testsuite/tests/printer/PprRecordDotSyntaxA.hs"
 
 -- exact = ppr
 
diff --git a/utils/check-exact/Test.hs b/utils/check-exact/Test.hs
index bb901f163d..c53a143626 100644
--- a/utils/check-exact/Test.hs
+++ b/utils/check-exact/Test.hs
@@ -39,8 +39,8 @@ import GHC
 
 tt :: IO ()
 -- tt = testOneFile "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
-tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
--- tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
+-- tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
+tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
  -- "cases/RenameCase1.hs" changeRenameCase1
  -- "cases/LayoutLet2.hs" changeLayoutLet2
  -- "cases/LayoutLet3.hs" changeLayoutLet3
diff --git a/utils/check-exact/check-exact.cabal b/utils/check-exact/check-exact.cabal
index 1eb1475484..438ff6a026 100644
--- a/utils/check-exact/check-exact.cabal
+++ b/utils/check-exact/check-exact.cabal
@@ -29,4 +29,5 @@ Executable check-exact
                    Cabal      >= 3.0 && < 3.6,
                    directory,
                    filepath,
-                   ghc
+                   ghc,
+                   mtl
diff --git a/utils/check-exact/src/ExactPrint.hs b/utils/check-exact/src/ExactPrint.hs
index bb2ef3df1a..7d2123d9a3 100644
--- a/utils/check-exact/src/ExactPrint.hs
+++ b/utils/check-exact/src/ExactPrint.hs
@@ -1106,7 +1106,8 @@ instance ExactPrint FastString where
   getAnnotationEntry = const NoEntryVal
 
   -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.
-  exact fs = printStringAdvance (show (unpackFS fs))
+  -- exact fs = printStringAdvance (show (unpackFS fs))
+  exact fs = printStringAdvance (unpackFS fs)
 
 
 -- ---------------------------------------------------------------------
@@ -1969,6 +1970,8 @@ instance ExactPrint (HsExpr GhcPs) where
   getAnnotationEntry (ExplicitList an _)          = fromAnn an
   getAnnotationEntry (RecordCon an _ _)           = fromAnn an
   getAnnotationEntry (RecordUpd an _ _)           = fromAnn an
+  getAnnotationEntry (HsGetField an _ _)          = fromAnn an
+  getAnnotationEntry (HsProjection an _)          = fromAnn an
   getAnnotationEntry (ExprWithTySig an _ _)       = fromAnn an
   getAnnotationEntry (ArithSeq an _ _)            = fromAnn an
   getAnnotationEntry (HsBracket an _)             = fromAnn an
@@ -2125,6 +2128,16 @@ instance ExactPrint (HsExpr GhcPs) where
     markApiAnn an AnnOpenC
     markAnnotated fields
     markApiAnn an AnnCloseC
+  exact x@(HsGetField an expr field) = do
+    -- error $ "HsGetField:" ++ showAst x
+    markAnnotated expr
+    -- markKwM an xxx AnnDot
+    markAnnotated field
+  exact x@(HsProjection an flds) = do
+    -- error $ "HsProjection:" ++ showAst x
+    markAnnKw an apOpen AnnOpenP
+    markAnnotated flds
+    markAnnKw an apClose AnnCloseP
   exact (ExprWithTySig an expr sig) = do
     markAnnotated expr
     markApiAnn an AnnDcolon
@@ -2354,6 +2367,19 @@ instance (ExactPrint body)
 
 -- ---------------------------------------------------------------------
 
+instance (ExactPrint body)
+    => ExactPrint (HsRecField' (FieldLabelStrings GhcPs) body) where
+  getAnnotationEntry x = fromAnn (hsRecFieldAnn x)
+  exact (HsRecField an f arg isPun) = do
+    debugM $ "HsRecField FieldLabelStrings"
+    markAnnotated f
+    if isPun then return ()
+             else do
+      markApiAnn an AnnEqual
+      markAnnotated arg
+
+-- ---------------------------------------------------------------------
+
 -- instance ExactPrint (HsRecUpdField GhcPs ) where
 instance (ExactPrint body)
     => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) body) where
@@ -2368,6 +2394,49 @@ instance (ExactPrint body)
     markAnnotated arg
 
 -- ---------------------------------------------------------------------
+-- instance (ExactPrint body)
+--     => ExactPrint (Either (HsRecField' (AmbiguousFieldOcc GhcPs) body)
+--                           (HsRecField' (FieldOcc GhcPs) body)) where
+--   getAnnotationEntry = const NoEntryVal
+--   exact (Left rbinds) = markAnnotated rbinds
+--   exact (Right pbinds) = markAnnotated pbinds
+
+-- ---------------------------------------------------------------------
+-- instance (ExactPrint body)
+--     => ExactPrint
+--          (Either [LocatedA (HsRecField' (AmbiguousFieldOcc GhcPs) body)]
+--                  [LocatedA (HsRecField' (FieldOcc GhcPs) body)]) where
+--   getAnnotationEntry = const NoEntryVal
+--   exact (Left rbinds) = markAnnotated rbinds
+--   exact (Right pbinds) = markAnnotated pbinds
+
+-- ---------------------------------------------------------------------
+instance -- (ExactPrint body)
+    (ExactPrint (HsRecField' (a GhcPs) body),
+     ExactPrint (HsRecField' (b GhcPs) body))
+    => ExactPrint
+         (Either [LocatedA (HsRecField' (a GhcPs) body)]
+                 [LocatedA (HsRecField' (b GhcPs) body)]) where
+  getAnnotationEntry = const NoEntryVal
+  exact (Left rbinds) = markAnnotated rbinds
+  exact (Right pbinds) = markAnnotated pbinds
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (FieldLabelStrings GhcPs) where
+  getAnnotationEntry = const NoEntryVal
+  exact (FieldLabelStrings fs) = markAnnotated fs
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (HsFieldLabel GhcPs) where
+  getAnnotationEntry (HsFieldLabel an _) = fromAnn an
+
+  exact (HsFieldLabel an fs) = do
+    markAnnKwM an afDot  AnnDot
+    markAnnotated fs
+
+-- ---------------------------------------------------------------------
 
 instance ExactPrint (HsTupArg GhcPs) where
   getAnnotationEntry (Present an _) = fromAnn an
@@ -2779,7 +2848,9 @@ instance ExactPrint (TyClDecl GhcPs) where
           annotationsToComments (apiAnnAnns an)  [AnnOpenP, AnnCloseP]
           markApiAnn an AnnClass
           exactVanillaDeclHead an lclas tyvars fixity context
-          -- markAnnotated fundeps
+          unless (null fds) $ do
+            markApiAnn an AnnVbar
+            markAnnotated fds
           markApiAnn an AnnWhere
 
 --   -- -----------------------------------
@@ -2842,6 +2913,15 @@ instance ExactPrint (TyClDecl GhcPs) where
 
 -- ---------------------------------------------------------------------
 
+instance ExactPrint (FunDep GhcPs) where
+  getAnnotationEntry (FunDep an _ _) = fromAnn an
+
+  exact (FunDep an ls rs) = do
+    markAnnotated ls
+    markApiAnn an AnnRarrow
+    markAnnotated rs
+-- ---------------------------------------------------------------------
+
 instance ExactPrint (FamilyDecl GhcPs) where
   getAnnotationEntry (FamilyDecl { fdExt = an }) = fromAnn an
 
diff --git a/utils/haddock b/utils/haddock
-Subproject d8ee717d6deb67c8ffae663846cefff6c8929b1
+Subproject a44de5aedef457a5a7850b276f02dcf1f071a35