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

Updates haddock submodule

36 files changed, 160 insertions, 77 deletions

diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs
index c63981bc71..cc66b1caf5 100644
--- a/compiler/GHC/Core/PatSyn.hs
+++ b/compiler/GHC/Core/PatSyn.hs
@@ -38,6 +38,8 @@ import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import qualified Data.Data as Data
 import Data.Function
 import Data.List (find)
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index 236610c3a8..7f7f10333b 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -174,6 +174,8 @@ import GHC.Utils.Misc
 import GHC.Types.Unique.Set
 import GHC.Unit.Module
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import qualified Data.Data as Data
 
 {-
@@ -1803,12 +1805,12 @@ tyConFieldLabelEnv tc
 
 -- | Look up a field label belonging to this 'TyCon'
 lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel
-lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl
+lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) (field_label lbl)
 
 -- | Make a map from strings to FieldLabels from all the data
 -- constructors of this algebraic tycon
 fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv
-fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl)
+fieldsOfAlgTcRhs rhs = mkDFsEnv [ (field_label $ flLabel fl, fl)
                                 | fl <- dataConsFields (visibleDataCons rhs) ]
   where
     -- Duplicates in this list will be removed by 'mkFsEnv'
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 405b772199..5b2ee9dc73 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -37,7 +37,7 @@ import GHC.Hs.Decls() -- import instances
 import GHC.Hs.Pat
 import GHC.Hs.Lit
 import Language.Haskell.Syntax.Extension
-import Language.Haskell.Syntax.Basic (FieldLabelString)
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 import GHC.Hs.Extension
 import GHC.Hs.Type
 import GHC.Hs.Binds
@@ -46,6 +46,7 @@ import GHC.Parser.Annotation
 -- others:
 import GHC.Tc.Types.Evidence
 import GHC.Types.Name
+import GHC.Types.Name.Reader
 import GHC.Types.Name.Set
 import GHC.Types.Basic
 import GHC.Types.Fixity
@@ -2121,8 +2122,11 @@ 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
+pprPrefixFastString :: FastString -> SDoc
+pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs)
+
+instance UnXRec p => Outputable (DotFieldOcc p) where
+  ppr (DotFieldOcc _ s) = (pprPrefixFastString . field_label . unXRec @p) s
   ppr XDotFieldOcc{} = text "XDotFieldOcc"
 
 {-
@@ -2157,8 +2161,10 @@ 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                = SrcSpanAnnN
+
 type instance Anno FastString                      = SrcAnn NoEpAnns
-              -- NB: type FieldLabelString = FastString
+  -- Used in HsQuasiQuote and perhaps elsewhere
 
 type instance Anno (DotFieldOcc (GhcPass p))       = SrcAnn NoEpAnns
 
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index a77ca82c7d..ac122446b7 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -89,6 +89,8 @@ import Data.Kind (Constraint)
 
 import qualified GHC.LanguageExtensions as LangExt
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Data.ByteString ( unpack )
 import Control.Monad
 import Data.List (sort, sortBy)
@@ -1635,10 +1637,10 @@ repE (HsUnboundVar _ uv)   = do
                                occ   <- occNameLit uv
                                sname <- repNameS occ
                                repUnboundVar sname
-repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ f)))) = do
+repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do
   e1 <- repLE e
   repGetField e1 f
-repE (HsProjection _ xs) = repProjection (fmap (unLoc . dfoLabel . unLoc) xs)
+repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs)
 repE (XExpr (HsExpanded orig_expr ds_expr))
   = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
        ; if rebindable_on  -- See Note [Quotation and rebindable syntax]
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 72f1002177..1affa46b42 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -78,6 +78,8 @@ import GHC.Utils.Panic
 import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
                        seqList, zipWithEqual )
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Control.Monad
 import System.IO.Unsafe
 import Control.DeepSeq
@@ -1262,7 +1264,7 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
       | otherwise      = Nothing
       where
         sel = flSelector lbl
-        occ = mkVarOccFS (flLabel lbl)
+        occ = mkVarOccFS (field_label $ flLabel lbl)
 
     mk_user_con_res_ty :: IfaceEqSpec -> SDoc
     -- See Note [Result type of a data family GADT]
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 280bbbfe43..904f566458 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -93,6 +93,8 @@ import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon,
                            unboxedUnitTyCon, unboxedUnitDataCon,
                            listTyCon_RDR, consDataCon_RDR)
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import qualified Data.Semigroup as Semi
 }
 
@@ -2881,8 +2883,8 @@ aexp1   :: { ECP }
         | aexp1 TIGHT_INFIX_PROJ field
             {% runPV (unECP $1) >>= \ $1 ->
                fmap ecpFromExp $ acsa (\cs ->
-                 let fl = sLLa $2 $> (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) (reLocA $3)) in
-                 mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (EpAnn (glAR $1) NoEpAnns cs))  }
+                 let fl = sLLa $2 (reLoc $>) (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in
+                 mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 fl (EpAnn (glAR $1) NoEpAnns cs))  }
 
 
         | aexp2                { $1 }
@@ -2967,8 +2969,8 @@ projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) }
 projection
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer
         : projection TIGHT_INFIX_PROJ field
-                             {% acs (\cs -> sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) (reLocA $3)) `NE.cons` unLoc $1)) }
-        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) (reLocA $2)) :| [])) }
+                             {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $2 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) }
+        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $1 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }
 
 splice_exp :: { LHsExpr GhcPs }
         : splice_untyped { mapLoc (HsUntypedSplice noAnn) (reLocA $1) }
@@ -3416,15 +3418,15 @@ fbind   :: { forall b. DisambECP b => PV (Fbind b) }
         -- AZ: need to pull out the let block into a helper
         | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp
                         { do
-                            let top = sL1a $1 $ DotFieldOcc noAnn (reLocA $1)
+                            let top = sL1 (la2la $1) $ DotFieldOcc noAnn $1
                                 ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)
                                 lf' = comb2 $2 (reLoc $ L lf ())
                                 fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t
                                 final = last fields
-                                l = comb2 $1 $3
+                                l = comb2 (reLoc $1) $3
                                 isPun = False
                             $5 <- unECP $5
-                            fmap Right $ mkHsProjUpdatePV (comb2 $1 (reLoc $5)) (L l fields) $5 isPun
+                            fmap Right $ mkHsProjUpdatePV (comb2 (reLoc $1) (reLoc $5)) (L l fields) $5 isPun
                                             [mj AnnEqual $4]
                         }
 
@@ -3432,24 +3434,24 @@ fbind   :: { forall b. DisambECP b => PV (Fbind b) }
         -- AZ: need to pull out the let block into a helper
         | field TIGHT_INFIX_PROJ fieldToUpdate
                         { do
-                            let top =  sL1a $1 $ DotFieldOcc noAnn (reLocA $1)
+                            let top =  sL1 (la2la $1) $ DotFieldOcc noAnn $1
                                 ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)
                                 lf' = comb2 $2 (reLoc $ L lf ())
                                 fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t
                                 final = last fields
-                                l = comb2 $1 $3
+                                l = comb2 (reLoc $1) $3
                                 isPun = True
-                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . dfoLabel . unLoc $ final))
+                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOcc . unpackFS . field_label . unLoc . dfoLabel . unLoc $ final))
                             fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []
                         }
 
 fieldToUpdate :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] }
 fieldToUpdate
         -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
-        : fieldToUpdate TIGHT_INFIX_PROJ field   {% getCommentsFor (getLoc $3) >>= \cs ->
-                                                     return (sLL $1 $> ((sLLa $2 $> (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) (reLocA $3))) : unLoc $1)) }
-        | field       {% getCommentsFor (getLoc $1) >>= \cs ->
-                        return (sL1 $1 [sL1a $1 (DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) (reLocA $1))]) }
+        : fieldToUpdate TIGHT_INFIX_PROJ field   {% getCommentsFor (getLocA $3) >>= \cs ->
+                                                     return (sLL $1 (reLoc $>) ((sLLa $2 (reLoc $>) (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }
+        | field       {% getCommentsFor (getLocA $1) >>= \cs ->
+                        return (sL1 (reLoc $1) [sL1a (reLoc $1) (DotFieldOcc (EpAnn (glNR $1) (AnnFieldLabel Nothing) cs) $1)]) }
 
 -----------------------------------------------------------------------------
 -- Implicit Parameter Bindings
@@ -3751,8 +3753,8 @@ qvar    :: { LocatedN RdrName }
 -- whether it's a qvar or a var can be postponed until
 -- *after* we see the close paren.
 
-field :: { Located FastString  }
-      : varid { reLocN $ fmap (occNameFS . rdrNameOcc) $1 }
+field :: { LocatedN FieldLabelString  }
+      : varid { fmap (FieldLabelString . occNameFS . rdrNameOcc) $1 }
 
 qvarid :: { LocatedN RdrName }
         : varid               { $1 }
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 3f99b1bfa4..9cce37e051 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -157,6 +157,8 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import qualified GHC.Data.Strict as Strict
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Control.Monad
 import Text.ParserCombinators.ReadP as ReadP
 import Data.Char
@@ -2561,7 +2563,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 (FieldLabelString f))
             lf = locA loc
         in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns
         where
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 5ade2db117..f69091c92d 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -70,6 +70,8 @@ import GHC.Data.Maybe          ( orElse )
 import GHC.Data.OrdList
 import qualified GHC.LanguageExtensions as LangExt
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Control.Monad
 import Data.Foldable      ( toList )
 import Data.List          ( partition, sortBy )
@@ -710,7 +712,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
                RecCon vars ->
                    do { checkDupRdrNames (map (foLabel . recordPatSynField) vars)
                       ; fls <- lookupConstructorFields name
-                      ; let fld_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
+                      ; let fld_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ]
                       ; let rnRecordPatSynField
                               (RecordPatSynField { recordPatSynField  = visible
                                                  , recordPatSynPatVar = hidden })
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 14916fb9f6..29184bf7f5 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -104,6 +104,7 @@ import Control.Arrow    ( first )
 import GHC.Types.FieldLabel
 import GHC.Data.Bag
 import GHC.Types.PkgQual
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
 {-
 *********************************************************
@@ -498,7 +499,7 @@ lookupRecFieldOcc mb_con rdr_name
   = lookupExactOrOrig rdr_name id $  -- See Note [Record field names and Template Haskell]
     do { flds <- lookupConstructorFields con
        ; env <- getGlobalRdrEnv
-       ; let lbl      = occNameFS (rdrNameOcc rdr_name)
+       ; let lbl      = FieldLabelString $ occNameFS (rdrNameOcc rdr_name)
              mb_field = do fl <- find ((== lbl) . flLabel) flds
                            -- We have the label, now check it is in scope.  If
                            -- there is a qualifier, use pickGREs to check that
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index b0f13dfc12..642ffb04c4 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -73,6 +73,8 @@ import Control.Monad
 import GHC.Builtin.Types ( nilDataConName )
 import qualified GHC.LanguageExtensions as LangExt
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Data.List (unzip4, minimumBy)
 import Data.List.NonEmpty ( NonEmpty(..) )
 import Data.Maybe (isJust, isNothing)
@@ -2730,11 +2732,11 @@ mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)
 -- mkSetField a field b calculates a set_field @field expression.
 -- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b").
 mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn
-mkSetField set_field a (L _ field) b =
+mkSetField set_field a (L _ (FieldLabelString field)) b =
   genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field)  a) b
 
 mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn]
-mkGet get_field l@(r : _) (L _ field) =
+mkGet get_field l@(r : _) (L _ (FieldLabelString field)) =
   wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l
 mkGet _ [] _ = panic "mkGet : The impossible has happened!"
 
@@ -2751,7 +2753,7 @@ mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fie
     f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc]
 
     proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
-    proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f
+    proj (L _ (FieldLabelString f)) = genHsVar getFieldName `genAppType` genHsTyLit f
 
 -- mkProjUpdateSetField calculates functions representing dot notation record updates.
 -- e.g. Suppose an update like foo.bar = 1.
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index ca83adcd01..8a9fdf6542 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -78,6 +78,8 @@ import GHC.Utils.Panic.Plain
 import GHC.Data.Maybe
 import qualified GHC.LanguageExtensions as LangExt
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Data.List (sortBy, nubBy, partition)
 import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty (NonEmpty(..))
@@ -1282,7 +1284,7 @@ rnConDeclFields ctxt fls fields
    = mapFvRn (rnField fl_env env) fields
   where
     env    = mkTyKiEnv ctxt TypeLevel RnTypeBody
-    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
+    fl_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ]
 
 rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
         -> RnM (LConDeclField GhcRn, FreeVars)
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 83f254b132..daaf128ea1 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -86,6 +86,8 @@ import GHC.Data.Maybe
 import GHC.Data.FastString
 import GHC.Data.FastString.Env
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Control.Monad
 import Data.Either      ( partitionEithers )
 import Data.Map         ( Map )
@@ -993,7 +995,7 @@ getLocalNonValBinders fixity_env
         find_con_decl_fld  (L _ (FieldOcc _ (L _ rdr)))
           = expectJust "getLocalNonValBinders/find_con_decl_fld" $
               find (\ fl -> flLabel fl == lbl) flds
-          where lbl = occNameFS (rdrNameOcc rdr)
+          where lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr)
 
     new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs
               -> RnM ([AvailInfo], [(Name, [FieldLabel])])
@@ -1055,7 +1057,7 @@ newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld)))
                              , flHasFieldSelector = has_sel
                              , flSelector = selName } }
   where
-    fieldLabelString = occNameFS $ rdrNameOcc fld
+    fieldLabelString = FieldLabelString $ occNameFS $ rdrNameOcc fld
     selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) dup_fields_ok has_sel
     field | isExact fld = fld
               -- use an Exact RdrName as is to preserve the bindings
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 2d6cb57bd1..f6f3ba0799 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -82,6 +82,7 @@ import qualified Data.List.NonEmpty as NE
 import Data.Maybe
 import Data.Ratio
 import GHC.Types.FieldLabel (DuplicateRecordFields(..))
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
 {-
 *********************************************************
@@ -822,7 +823,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                  (dot_dot_fields, dot_dot_gres)
                         = unzip [ (fl, gre)
                                 | fl <- con_fields
-                                , let lbl = mkVarOccFS (flLabel fl)
+                                , let lbl = mkVarOccFS (field_label $ flLabel fl)
                                 , not (lbl `elemOccSet` present_flds)
                                 , Just gre <- [lookupGRE_FieldLabel rdr_env fl]
                                               -- Check selector is in scope
@@ -840,7 +841,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                         , hfbPun      = False })
                     | fl <- dot_dot_fields
                     , let sel     = flSelector fl
-                    , let arg_rdr = mkVarUnqual (flLabel fl) ] }
+                    , let arg_rdr = mkVarUnqual (field_label $ flLabel fl) ] }
 
     rn_dotdot _dotdot _mb_con _flds
       = return []
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index ab0bbd0c11..4cacf36013 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -46,6 +46,7 @@ import GHC.Prelude
 
 import GHC.Tc.Utils.Monad
 import GHC.Hs
+import GHC.Types.FieldLabel
 import GHC.Types.Name.Reader
 import GHC.Types.Basic
 import GHC.Types.Fixity
@@ -84,6 +85,8 @@ import GHC.Data.FastString
 import GHC.Data.Pair
 import GHC.Data.Bag
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Data.List  ( find, partition, intersperse )
 import GHC.Data.Maybe ( expectJust )
 import GHC.Unit.Module
@@ -1110,7 +1113,7 @@ gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon})
         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 
         con_arity    = dataConSourceArity data_con
-        labels       = map flLabel $ dataConFieldLabels data_con
+        labels       = map (field_label . flLabel) $ dataConFieldLabels data_con
         dc_nm        = getName data_con
         is_infix     = dataConIsInfix data_con
         is_record    = labels `lengthExceeds` 0
@@ -1234,7 +1237,7 @@ gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon
              arg_tys       = derivDataConInstArgTys data_con dit -- Correspond 1-1 with bs_needed
              con_pat       = nlConVarPat data_con_RDR bs_needed
              nullary_con   = con_arity == 0
-             labels        = map flLabel $ dataConFieldLabels data_con
+             labels        = map (field_label . flLabel) $ dataConFieldLabels data_con
              lab_fields    = length labels
              record_syntax = lab_fields > 0
 
@@ -2200,7 +2203,7 @@ genAuxBindSpecOriginal dflags loc spec
              , nlList  labels                               -- Field labels
              , nlHsVar fixity ]                             -- Fixity
 
-        labels   = map (nlHsLit . mkHsString . unpackFS . flLabel)
+        labels   = map (nlHsLit . mkHsString . unpackFS . field_label . flLabel)
                        (dataConFieldLabels dc)
         dc_occ   = getOccName dc
         is_infix = isDataSymOcc dc_occ
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index bae4ca79bf..85a73274ce 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -58,6 +58,8 @@ import GHC.Utils.Panic.Plain
 import GHC.Data.FastString
 import GHC.Utils.Misc
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Control.Monad (mplus)
 import Data.List (zip4, partition)
 import Data.Maybe (isJust)
@@ -639,7 +641,7 @@ tc_mkRepTy gk get_fixity dit@(DerivInstTys{ dit_rep_tc = tycon
                               then promotedTrueDataCon
                               else promotedFalseDataCon
 
-        selName = mkStrLitTy . flLabel
+        selName = mkStrLitTy . field_label . flLabel
 
         mbSel Nothing  = mkTyConApp promotedNothingDataCon [typeSymbolKind]
         mbSel (Just s) = mkTyConApp promotedJustDataCon
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index e8c3c6e411..96bf0b7127 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -81,7 +81,6 @@ import GHC.Tc.Types.Rank (Rank)
 import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType)
 import GHC.Types.Error
 import GHC.Types.Hint (UntickedPromotedThing(..))
-import GHC.Types.FieldLabel (FieldLabelString)
 import GHC.Types.ForeignCall (CLabelString)
 import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan)
 import GHC.Types.Name.Reader
@@ -109,6 +108,8 @@ import GHC.Utils.Misc (capitalise, filterOut)
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Data.FastString (FastString)
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import qualified Data.List.NonEmpty as NE
 import           Data.Typeable hiding (TyCon)
 import qualified Data.Semigroup as Semigroup
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 204114bb5b..6a4eb7f6f1 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -37,6 +37,7 @@ import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Unify
 import GHC.Types.Basic
 import GHC.Types.Error
+import GHC.Types.FieldLabel
 import GHC.Types.Unique.Map ( UniqMap, listToUniqMap, lookupUniqMap )
 import GHC.Core.Multiplicity
 import GHC.Core.UsageEnv
@@ -84,6 +85,8 @@ import Control.Monad
 import GHC.Core.Class(classTyCon)
 import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Data.Function
 import Data.List (partition, sortBy, groupBy, intersect)
 
@@ -1208,7 +1211,7 @@ desugarRecordUpd record_expr rbnds res_ty
        -- After this we know that rbinds is unambiguous
        ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
        ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds
-             upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
+             upd_fld_occs = map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
              sel_ids      = map selectorAmbiguousFieldOcc upd_flds
              upd_fld_names = map idName sel_ids
 
@@ -1355,7 +1358,7 @@ desugarRecordUpd record_expr rbnds res_ty
                  Just (upd_id, _) -> (genWildPat, genLHsVar (idName upd_id))
                  -- Field is not being updated: LHS = variable pattern, RHS = that same variable.
                  _  -> let fld_nm = mkInternalName (mkBuiltinUnique i)
-                                      (mkVarOccFS (flLabel fld_lbl))
+                                      (mkVarOccFS (field_label $ flLabel fld_lbl))
                                       generatedSrcSpan
                        in (genVarPat fld_nm, genLHsVar fld_nm)
 
@@ -1599,7 +1602,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
       = do { addErrTc (badFieldConErr (getName con_like) field_lbl)
            ; return Nothing }
   where
-        field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
+        field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc (unLoc lbl)
 
 
 checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
@@ -1705,7 +1708,7 @@ badFieldsUpd rbinds data_cons
     membership :: [(FieldLabelString, [Bool])]
     membership = sortMembership $
         map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $
-          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds
+          map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds
 
     fieldLabelSets :: [UniqSet FieldLabelString]
     fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index b5c6b4c5c5..4df4307737 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -37,6 +37,7 @@ import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags )
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Instantiate
 import GHC.Types.Error
+import GHC.Types.FieldLabel
 import GHC.Types.Id
 import GHC.Types.Var
 import GHC.Types.Name
@@ -70,8 +71,10 @@ import GHC.Utils.Panic.Plain
 import qualified GHC.LanguageExtensions as LangExt
 import Control.Arrow  ( second )
 import Control.Monad
+import GHC.Data.FastString
 import qualified Data.List.NonEmpty as NE
 import GHC.Data.List.SetOps ( getNth )
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
 {-
 ************************************************************************
@@ -1296,7 +1299,7 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of
                                                                         pun), res) }
 
 
-      find_field_ty :: Name -> FieldLabelString -> TcM (Scaled TcType)
+      find_field_ty :: Name -> FastString -> TcM (Scaled TcType)
       find_field_ty sel lbl
         = case [ty | (fl, ty) <- field_tys, flSelector fl == sel ] of
 
@@ -1306,7 +1309,7 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of
                 --      f (R { foo = (a,b) }) = a+b
                 -- If foo isn't one of R's fields, we don't want to crash when
                 -- typechecking the "a+b".
-           [] -> failWith (badFieldConErr (getName con_like) lbl)
+           [] -> failWith (badFieldConErr (getName con_like) (FieldLabelString lbl))
 
                 -- The normal case, when the field comes from the right constructor
            (pat_ty : extras) -> do
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 52205cd944..251d17c27f 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -132,6 +132,7 @@ import GHC.Data.FastString
 import GHC.Data.Maybe( MaybeErr(..) )
 import qualified GHC.Data.EnumSet as EnumSet
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 import qualified Language.Haskell.TH as TH
 -- THSyntax gives access to internal functions and data types
 import qualified Language.Haskell.TH.Syntax as TH
@@ -2762,7 +2763,7 @@ reifyFieldLabel fl
     mod     = assert (isExternalName name) $ nameModule name
     pkg_str = unitString (moduleUnit mod)
     mod_str = moduleNameString (moduleName mod)
-    occ_str = unpackFS (flLabel fl)
+    occ_str = unpackFS (field_label $ flLabel fl)
 
 reifySelector :: Id -> TyCon -> TH.Name
 reifySelector id tc
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 2993d02ab6..2bac6fa3ab 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -28,6 +28,7 @@ import GHC.Builtin.Types
 import GHC.Builtin.Types.Prim
 import GHC.Builtin.Names
 
+import GHC.Types.FieldLabel
 import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName )
 import GHC.Types.SafeHaskell
 import GHC.Types.Name   ( Name, pprDefinedAt )
@@ -51,6 +52,8 @@ import GHC.Utils.Panic
 import GHC.Utils.Misc( splitAtList, fstOf3 )
 import GHC.Data.FastString
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Data.Maybe
 
 {- *******************************************************************
@@ -917,7 +920,7 @@ matchHasField dflags short_cut clas tys
                -- use representation tycon (if data family); it has the fields
              , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
                -- x should be a field of r
-             , Just fl <- lookupTyConFieldLabel x r_tc
+             , Just fl <- lookupTyConFieldLabel (FieldLabelString x) r_tc
                -- the field selector should be in scope
              , Just gre <- lookupGRE_FieldLabel rdr_env fl
 
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 03e7d45148..145f1b26f2 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -98,6 +98,8 @@ import GHC.Utils.Panic.Plain
 import GHC.Utils.Constants (debugIsOn)
 import GHC.Utils.Misc
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Control.Monad
 import Data.Functor.Identity
 import Data.List ( partition)
@@ -4270,7 +4272,7 @@ checkValidTyCon tc
     -- The order of these equivalence classes might conceivably (non-deterministically)
     -- depend on the result of this comparison, but that just affects the order in which
     -- fields are checked for compatibility. It will not affect the compiled binary.
-    cmp_fld (f1,_) (f2,_) = flLabel f1 `uniqCompareFS` flLabel f2
+    cmp_fld (f1,_) (f2,_) = field_label (flLabel f1) `uniqCompareFS` field_label (flLabel f2)
     get_fields con = dataConFieldLabels con `zip` repeat con
         -- dataConFieldLabels may return the empty list, which is fine
 
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index a77d6be317..2ca71dec1b 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -81,6 +81,8 @@ import GHC.Types.Unique.Set
 import GHC.Types.TyThing
 import qualified GHC.LanguageExtensions as LangExt
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Control.Monad
 
 {-
@@ -935,7 +937,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
                         { hfbAnn = noAnn
                         , hfbLHS
                            = L locc (FieldOcc sel_name
-                                      (L locn $ mkVarUnqual lbl))
+                                      (L locn $ mkVarUnqual (field_label lbl)))
                         , hfbRHS
                            = L loc' (VarPat noExtField (L locn field_var))
                         , hfbPun = False })
@@ -982,7 +984,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
     inst_tys = substTyVars eq_subst univ_tvs
 
     unit_rhs = mkLHsTupleExpr [] noExtField
-    msg_lit = HsStringPrim NoSourceText (bytesFS lbl)
+    msg_lit = HsStringPrim NoSourceText (bytesFS (field_label lbl))
 
 {-
 Note [Polymorphic selectors]
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 1b7d4de3fd..94801fb0df 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -68,6 +68,8 @@ import GHC.Utils.Monad
 import GHC.Types.Unique
 import GHC.Types.Unique.Supply
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 {- *********************************************************************
 *                                                                      *
           UserTypeCtxt
@@ -673,7 +675,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e
 
 exprCtOrigin :: HsExpr GhcRn -> CtOrigin
 exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
-exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ dfoLabel f)
+exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (field_label $ unLoc $ dfoLabel f)
 exprCtOrigin (HsUnboundVar {})    = Shouldn'tHappenOrigin "unbound variable"
 exprCtOrigin (HsRecSel _ f)       = OccurrenceOfRecSel (unLoc $ foLabel f)
 exprCtOrigin (HsOverLabel _ l)    = OverLabelOrigin l
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index d6a5b15dbb..bfad7b7d38 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -72,6 +72,8 @@ import GHC.Utils.Panic
 import GHC.Builtin.Uniques  ( mkAlphaTyVarUnique )
 import qualified GHC.LanguageExtensions as LangExt
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Control.Monad
 import Data.Foldable
 import Data.Function
@@ -1581,7 +1583,7 @@ checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] =
                   -> whoops (text "Record data type may not be a data family")
       | otherwise -> case isStrLitTy x_ty of
        Just lbl
-         | isJust (lookupTyConFieldLabel lbl tc)
+         | isJust (lookupTyConFieldLabel (FieldLabelString lbl) tc)
                      -> whoops (ppr tc <+> text "already has a field"
                                        <+> quotes (ppr lbl))
          | otherwise -> return ()
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 8d795d7fe2..5ba99fe7ac 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -55,6 +55,8 @@ import GHC.Data.FastString
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import qualified Data.ByteString as BS
 import Control.Monad( unless, ap )
 import Control.Applicative( (<|>) )
@@ -1106,8 +1108,10 @@ cvtl e = wrapLA (cvt e)
     cvt (LabelE s)       = return $ HsOverLabel noComments (fsLit s)
     cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' }
     cvt (GetFieldE exp f) = do { e' <- cvtl exp
-                               ; return $ HsGetField noComments e' (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (fsLit f)))) }
-    cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . fsLit) xs
+                               ; return $ HsGetField noComments e'
+                                         (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) }
+    cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap
+                                         (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString  . fsLit) xs
 
 {- | #16895 Ensure an infix expression's operator is a variable/constructor.
 Consider this example:
diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs
index 4521b06874..d1da25ca08 100644
--- a/compiler/GHC/Types/FieldLabel.hs
+++ b/compiler/GHC/Types/FieldLabel.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable FieldLabelString
 
 {-
 %
@@ -71,8 +72,7 @@ Of course, datatypes with no constructors cannot have any fields.
 -}
 
 module GHC.Types.FieldLabel
-   ( FieldLabelString
-   , FieldLabelEnv
+   ( FieldLabelEnv
    , FieldLabel(..)
    , fieldSelectorOccName
    , fieldLabelPrintableName
@@ -89,10 +89,11 @@ import {-# SOURCE #-} GHC.Types.Name
 
 import GHC.Data.FastString
 import GHC.Data.FastString.Env
+import GHC.Types.Unique (Uniquable(..))
 import GHC.Utils.Outputable
 import GHC.Utils.Binary
 
-import Language.Haskell.Syntax.Basic (FieldLabelString)
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
 import Data.Bool
 import Data.Data
@@ -115,13 +116,20 @@ data FieldLabel = FieldLabel {
   deriving (Data, Eq)
 
 instance HasOccName FieldLabel where
-  occName = mkVarOccFS . flLabel
+  occName = mkVarOccFS . field_label . flLabel
 
 instance Outputable FieldLabel where
     ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl))
                                                 <> ppr (flHasDuplicateRecordFields fl)
                                                 <> ppr (flHasFieldSelector fl))
 
+instance Outputable FieldLabelString where
+  ppr (FieldLabelString l) = ppr l
+
+instance Uniquable FieldLabelString where
+  getUnique (FieldLabelString fs) = getUnique fs
+
+
 -- | Flag to indicate whether the DuplicateRecordFields extension is enabled.
 data DuplicateRecordFields
     = DuplicateRecordFields   -- ^ Fields may be duplicated in a single module
@@ -158,7 +166,7 @@ instance Outputable FieldSelectors where
 -- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name".
 instance Binary Name => Binary FieldLabel where
     put_ bh (FieldLabel aa ab ac ad) = do
-        put_ bh aa
+        put_ bh (field_label aa)
         put_ bh ab
         put_ bh ac
         put_ bh ad
@@ -167,7 +175,7 @@ instance Binary Name => Binary FieldLabel where
         ab <- get bh
         ac <- get bh
         ad <- get bh
-        return (FieldLabel aa ab ac ad)
+        return (FieldLabel (FieldLabelString aa) ab ac ad)
 
 
 -- | Record selector OccNames are built from the underlying field name
@@ -177,9 +185,10 @@ instance Binary Name => Binary FieldLabel where
 fieldSelectorOccName :: FieldLabelString -> OccName -> DuplicateRecordFields -> FieldSelectors -> OccName
 fieldSelectorOccName lbl dc dup_fields_ok has_sel
   | shouldMangleSelectorNames dup_fields_ok has_sel = mkRecFldSelOcc str
-  | otherwise     = mkVarOccFS lbl
+  | otherwise     = mkVarOccFS fl
   where
-    str     = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc
+    fl      = field_label lbl
+    str     = ":" ++ unpackFS fl ++ ":" ++ occNameString dc
 
 -- | Undo the name mangling described in Note [FieldLabel] to produce a Name
 -- that has the user-visible OccName (but the selector's unique).  This should
@@ -187,7 +196,7 @@ fieldSelectorOccName lbl dc dup_fields_ok has_sel
 -- need to qualify it with a module prefix.
 fieldLabelPrintableName :: FieldLabel -> Name
 fieldLabelPrintableName fl
-  | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (flLabel fl))
+  | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (field_label $ flLabel fl))
   | otherwise         = flSelector fl
 
 -- | Selector name mangling should be used if either DuplicateRecordFields or
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index 55005e4129..df624838c3 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -93,6 +93,8 @@ import GHC.Utils.Misc as Utils
 import GHC.Utils.Panic
 import GHC.Types.Name.Env
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Data.Data
 import Data.List( sortBy )
 import GHC.Data.Bag
@@ -867,7 +869,7 @@ lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt
 -- selector name and field label may be different: the GlobalRdrEnv is keyed on
 -- the label.  See Note [GreNames] for why this happens.
 lookupGRE_FieldLabel env fl
-  = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl))
+  = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (field_label $ flLabel fl))
 
 lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt
 -- ^ Look for precisely this 'Name' in the environment, but with an 'OccName'
diff --git a/compiler/Language/Haskell/Syntax/Basic.hs b/compiler/Language/Haskell/Syntax/Basic.hs
index 092231b7d1..77ad3fe0e0 100644
--- a/compiler/Language/Haskell/Syntax/Basic.hs
+++ b/compiler/Language/Haskell/Syntax/Basic.hs
@@ -53,8 +53,8 @@ Field Labels
 
 -- | Field labels are just represented as strings;
 -- they are not necessarily unique (even within a module)
-type FieldLabelString = FastString
-
+newtype FieldLabelString = FieldLabelString { field_label:: FastString }
+  deriving (Data, Eq)
 
 {-
 ************************************************************************
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 326c9903dc..8dda0c8c81 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -1638,4 +1638,3 @@ isMonadDoCompContext ListComp     = False
 isMonadDoCompContext GhciStmtCtxt = False
 isMonadDoCompContext (DoExpr _)   = False
 isMonadDoCompContext (MDoExpr _)  = False
-
diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr
index b2e294562b..05401b78bb 100644
--- a/testsuite/tests/parser/should_compile/T14189.stderr
+++ b/testsuite/tests/parser/should_compile/T14189.stderr
@@ -188,7 +188,8 @@
        [(L
          { T14189.hs:3:11 }
          (FieldLabel
-          {FastString: "f"}
+          (FieldLabelString
+           {FastString: "f"})
           (NoDuplicateRecordFields)
           (FieldSelectors)
           {Name: T14189.f}))]
@@ -215,7 +216,8 @@
          {Name: T14189.NT})
        ,(FieldGreName
          (FieldLabel
-          {FastString: "f"}
+          (FieldLabelString
+           {FastString: "f"})
           (NoDuplicateRecordFields)
           (FieldSelectors)
           {Name: T14189.f}))])])])
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index e80655d83f..47640fa971 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -759,3 +759,8 @@ Test20846:
 Test20256:
 	$(CHECK_PPR)   $(LIBDIR) Test20256.hs
 	$(CHECK_EXACT) $(LIBDIR) Test20256.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 8a7b1533cd..3026099884 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -179,3 +179,4 @@ test('Test20258', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20258'])
 test('Test20297', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20297'])
 test('Test20315', normal, compile_fail, [''])
 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 eecb1e28eb..8ec3adbf46 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
@@ -39,6 +40,8 @@ import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.TypeLits
 
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+
 import Control.Monad.Identity
 import Control.Monad.RWS
 import Data.Data ( Data )
@@ -47,7 +50,6 @@ import Data.Typeable
 import Data.List ( partition, sortBy)
 import Data.List.NonEmpty ( NonEmpty )
 import Data.Maybe ( isJust )
-
 import Data.Void
 
 import Lookup
@@ -2270,9 +2272,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 (FieldLabelString 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 122c63990a..4272a8004c 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -38,7 +38,8 @@ import GHC.Data.FastString
 _tt :: IO ()
 -- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
 -- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
-_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
+_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib"
+-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
 
  -- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1)
  -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" (Just changeLayoutLet2)
@@ -198,7 +199,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_buil
  -- "../../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
 
diff --git a/utils/haddock b/utils/haddock
-Subproject 7bd04379ada2d9ff1c406d258629f8abdf617b3
+Subproject 4f8a875dec5db8795286a557779f3eb684718be