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

11 files changed, 42 insertions, 18 deletions

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 ()