summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2022-07-01 12:52:29 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-08-11 16:19:57 -0400
commitff67c79ee742024ca0ef41a9a7e540e1662d46bd (patch)
tree6588e16a80e86696f7541c483a724903b82ad492
parent5c24b1b3a9d6a4c2f471fd7d8ec65141a8b46357 (diff)
downloadhaskell-ff67c79ee742024ca0ef41a9a7e540e1662d46bd.tar.gz
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
-rw-r--r--compiler/GHC/Core/PatSyn.hs2
-rw-r--r--compiler/GHC/Core/TyCon.hs6
-rw-r--r--compiler/GHC/Hs/Expr.hs14
-rw-r--r--compiler/GHC/HsToCore/Quote.hs6
-rw-r--r--compiler/GHC/Iface/Syntax.hs4
-rw-r--r--compiler/GHC/Parser.y34
-rw-r--r--compiler/GHC/Parser/PostProcess.hs4
-rw-r--r--compiler/GHC/Rename/Bind.hs4
-rw-r--r--compiler/GHC/Rename/Env.hs3
-rw-r--r--compiler/GHC/Rename/Expr.hs8
-rw-r--r--compiler/GHC/Rename/HsType.hs4
-rw-r--r--compiler/GHC/Rename/Names.hs6
-rw-r--r--compiler/GHC/Rename/Pat.hs5
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs9
-rw-r--r--compiler/GHC/Tc/Deriv/Generics.hs4
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs3
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs11
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs7
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs3
-rw-r--r--compiler/GHC/Tc/Instance/Class.hs5
-rw-r--r--compiler/GHC/Tc/TyCl.hs4
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs6
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs4
-rw-r--r--compiler/GHC/Tc/Validity.hs4
-rw-r--r--compiler/GHC/ThToHs.hs8
-rw-r--r--compiler/GHC/Types/FieldLabel.hs27
-rw-r--r--compiler/GHC/Types/Name/Reader.hs4
-rw-r--r--compiler/Language/Haskell/Syntax/Basic.hs4
-rw-r--r--compiler/Language/Haskell/Syntax/Expr.hs1
-rw-r--r--testsuite/tests/parser/should_compile/T14189.stderr6
-rw-r--r--testsuite/tests/printer/Makefile5
-rw-r--r--testsuite/tests/printer/Test21805.hs3
-rw-r--r--testsuite/tests/printer/all.T1
-rw-r--r--utils/check-exact/ExactPrint.hs12
-rw-r--r--utils/check-exact/Main.hs6
m---------utils/haddock0
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