summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Hs/Expr.hs7
-rw-r--r--compiler/GHC/Hs/Instances.hs6
-rw-r--r--compiler/GHC/Parser.y28
-rw-r--r--compiler/GHC/Parser/PostProcess.hs10
-rw-r--r--compiler/GHC/Rename/Expr.hs16
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs2
-rw-r--r--compiler/Language/Haskell/Syntax/Expr.hs61
-rw-r--r--compiler/Language/Haskell/Syntax/Extension.hs6
8 files changed, 71 insertions, 65 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 89292b59c3..006c8a2e8e 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -44,6 +44,7 @@ import GHC.Parser.Annotation
-- others:
import GHC.Tc.Types.Evidence
+import GHC.Core.DataCon (FieldLabelString)
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Basic
@@ -406,8 +407,8 @@ data AnnsIf
type instance XSCC (GhcPass _) = EpAnn AnnPragma
type instance XXPragE (GhcPass _) = NoExtCon
-type instance XCHsFieldLabel (GhcPass _) = EpAnn AnnFieldLabel
-type instance XXHsFieldLabel (GhcPass _) = NoExtCon
+type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel
+type instance XXDotFieldOcc (GhcPass _) = NoExtCon
type instance XPresent (GhcPass _) = EpAnn [AddEpAnn]
@@ -1902,6 +1903,8 @@ 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)) = SrcSpan
+type instance Anno (FieldLabelString) = SrcSpan
+type instance Anno (DotFieldOcc (GhcPass p)) = SrcSpan
instance (Anno a ~ SrcSpanAnn' (EpAnn an))
=> WrapXRec (GhcPass p) a where
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index db7af75d9b..363b890d59 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -278,9 +278,9 @@ deriving instance Data (FieldLabelStrings GhcPs)
deriving instance Data (FieldLabelStrings GhcRn)
deriving instance Data (FieldLabelStrings GhcTc)
-deriving instance Data (HsFieldLabel GhcPs)
-deriving instance Data (HsFieldLabel GhcRn)
-deriving instance Data (HsFieldLabel GhcTc)
+deriving instance Data (DotFieldOcc GhcPs)
+deriving instance Data (DotFieldOcc GhcRn)
+deriving instance Data (DotFieldOcc GhcTc)
-- deriving instance (DataIdLR p p) => Data (HsPragE p)
deriving instance Data (HsPragE GhcPs)
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 363493482a..cc52d67469 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2858,7 +2858,7 @@ aexp1 :: { ECP }
| aexp1 TIGHT_INFIX_PROJ field
{% runPV (unECP $1) >>= \ $1 ->
fmap ecpFromExp $ acsa (\cs ->
- let fl = sLL $2 $> (HsFieldLabel ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in
+ let fl = sLL $2 $> (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in
mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (EpAnn (glAR $1) NoEpAnns cs)) }
@@ -2940,12 +2940,12 @@ aexp2 :: { ECP }
acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix
Nothing (reverse $3)) }
-projection :: { Located [Located (HsFieldLabel GhcPs)] }
+projection :: { Located [Located (DotFieldOcc GhcPs)] }
projection
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer
: projection TIGHT_INFIX_PROJ field
- {% acs (\cs -> sLL $1 $> ((sLL $2 $> $ HsFieldLabel (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) : unLoc $1)) }
- | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> [sLL $1 $> $ HsFieldLabel (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2]) }
+ {% acs (\cs -> sLL $1 $> ((sLL $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) : unLoc $1)) }
+ | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> [sLL $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2]) }
splice_exp :: { LHsExpr GhcPs }
: splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) }
@@ -3385,10 +3385,10 @@ 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 = sL1 $1 $ HsFieldLabel noAnn $1
- ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3)
+ let top = sL1 $1 $ DotFieldOcc noAnn $1
+ ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)
lf' = comb2 $2 (L lf ())
- fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t
+ fields = top : L lf' (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t
final = last fields
l = comb2 $1 $3
isPun = False
@@ -3401,24 +3401,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 = sL1 $1 $ HsFieldLabel noAnn $1
- ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3)
+ let top = sL1 $1 $ DotFieldOcc noAnn $1
+ ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)
lf' = comb2 $2 (L lf ())
- fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t
+ fields = top : L lf' (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t
final = last fields
l = comb2 $1 $3
isPun = True
- var <- mkHsVarPV (L (noAnnSrcSpan $ getLoc final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . hflLabel . unLoc $ final))
+ var <- mkHsVarPV (L (noAnnSrcSpan $ getLoc final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . dfoLabel . unLoc $ final))
fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []
}
-fieldToUpdate :: { Located [Located (HsFieldLabel GhcPs)] }
+fieldToUpdate :: { Located [Located (DotFieldOcc GhcPs)] }
fieldToUpdate
-- See Note [Whitespace-sensitive operator parsing] in Lexer.x
: fieldToUpdate TIGHT_INFIX_PROJ field {% getCommentsFor (getLoc $3) >>= \cs ->
- return (sLL $1 $> ((sLL $2 $> (HsFieldLabel (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }
+ return (sLL $1 $> ((sLL $2 $> (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }
| field {% getCommentsFor (getLoc $1) >>= \cs ->
- return (sL1 $1 [sL1 $1 (HsFieldLabel (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) $1)]) }
+ return (sL1 $1 [sL1 $1 (DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) $1)]) }
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index e29a8314ff..34c973fefc 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1431,7 +1431,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)
-- | Return an expression without ambiguity, or fail in a non-expression context.
ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)
- mkHsProjUpdatePV :: SrcSpan -> Located [Located (HsFieldLabel GhcPs)]
+ mkHsProjUpdatePV :: SrcSpan -> Located [Located (DotFieldOcc GhcPs)]
-> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))
-- | Disambiguate "\... -> ..." (lambda)
mkHsLamPV
@@ -2468,7 +2468,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 = HsFieldLabel noAnn (L lf f) -- AZ: what about the ann?
+ fl = DotFieldOcc noAnn (L lf f) -- AZ: what about the ann?
lf = locA loc
in mkRdrProjUpdate l (L lf [L lf fl]) (punnedVar f) pun anns
where
@@ -2991,7 +2991,7 @@ starSym False = "*"
-----------------------------------------
-- Bits and pieces for RecordDotSyntax.
-mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (HsFieldLabel GhcPs)
+mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (DotFieldOcc GhcPs)
-> EpAnnCO -> LHsExpr GhcPs
mkRdrGetField loc arg field anns =
L loc HsGetField {
@@ -3000,7 +3000,7 @@ mkRdrGetField loc arg field anns =
, gf_field = field
}
-mkRdrProjection :: [Located (HsFieldLabel GhcPs)] -> EpAnn AnnProjection -> HsExpr GhcPs
+mkRdrProjection :: [Located (DotFieldOcc GhcPs)] -> EpAnn AnnProjection -> HsExpr GhcPs
mkRdrProjection [] _ = panic "mkRdrProjection: The impossible has happened!"
mkRdrProjection flds anns =
HsProjection {
@@ -3008,7 +3008,7 @@ mkRdrProjection flds anns =
, proj_flds = flds
}
-mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (HsFieldLabel GhcPs)]
+mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (DotFieldOcc GhcPs)]
-> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn]
-> LHsRecProj GhcPs (LHsExpr GhcPs)
mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!"
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 564eabb601..aff3ce3dbd 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -309,19 +309,19 @@ rnExpr (NegApp _ e _)
rnExpr (HsGetField _ e f)
= do { (getField, fv_getField) <- lookupSyntaxName getFieldName
; (e, fv_e) <- rnLExpr e
- ; let f' = rnHsFieldLabel f
+ ; let f' = rnDotFieldOcc f
; return ( mkExpandedExpr
(HsGetField noExtField e f')
- (mkGetField getField e (fmap (unLoc . hflLabel) f'))
+ (mkGetField getField e (fmap (unLoc . dfoLabel) f'))
, fv_e `plusFV` fv_getField ) }
rnExpr (HsProjection _ fs)
= do { (getField, fv_getField) <- lookupSyntaxName getFieldName
; circ <- lookupOccRn compose_RDR
- ; let fs' = fmap rnHsFieldLabel fs
+ ; let fs' = fmap rnDotFieldOcc fs
; return ( mkExpandedExpr
(HsProjection noExtField fs')
- (mkProjection getField circ (map (fmap (unLoc . hflLabel)) fs'))
+ (mkProjection getField circ (map (fmap (unLoc . dfoLabel)) fs'))
, unitFV circ `plusFV` fv_getField) }
------------------------------------------
@@ -702,11 +702,11 @@ See #18151.
************************************************************************
-}
-rnHsFieldLabel :: Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)
-rnHsFieldLabel (L l (HsFieldLabel x label)) = L l (HsFieldLabel x label)
+rnDotFieldOcc :: Located (DotFieldOcc GhcPs) -> Located (DotFieldOcc GhcRn)
+rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)
rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
-rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnHsFieldLabel fls)
+rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnDotFieldOcc fls)
{-
************************************************************************
@@ -2618,7 +2618,7 @@ mkProjection _ _ [] = panic "mkProjection: The impossible happened"
mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)
mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } ))
= let {
- ; flds = map (fmap (unLoc . hflLabel)) flds'
+ ; flds = map (fmap (unLoc . dfoLabel)) flds'
; final = last flds -- quux
; fields = init flds -- [foo, bar, baz]
; getters = \a -> foldl' (mkGet get_field) [a] fields -- Ordered from deep to shallow.
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 6a67a33e5b..02c5c351e7 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -495,7 +495,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e
exprCtOrigin :: HsExpr GhcRn -> CtOrigin
exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
-exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ hflLabel f)
+exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (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/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index b4d7b24dea..88f15515c8 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -97,19 +97,20 @@ neither record constructions).
The results of these new rules cannot be represented by @LHsRecField
GhcPs (LHsExpr GhcPs)@ values as the type is defined today. We
minimize modifying existing code by having these new rules calculate
-@LHsRecProj GhcPs (Located b)@ ("record projection") values instead:
+@LHsRecProj GhcPs (LHsExpr GhcPs)@ ("record projection") values
+instead:
@
-newtype FieldLabelStrings = FieldLabelStrings [Located FieldLabelString]
+newtype FieldLabelStrings = FieldLabelStrings [XRec p (DotFieldOcc p)]
type RecProj arg = HsFieldBind FieldLabelStrings arg
-type LHsRecProj p arg = Located (RecProj arg)
+type LHsRecProj p arg = XRec p (RecProj arg)
@
The @fbind@ rule is then given the type @fbind :: { forall b.
DisambECP b => PV (Fbind b) }@ accomodating both alternatives:
@
type Fbind b = Either
- (LHsRecField GhcPs (Located b))
- ( LHsRecProj GhcPs (Located b))
+ (LHsRecField GhcPs (LocatedA b))
+ ( LHsRecProj GhcPs (LocatedA b))
@
In @data HsExpr p@, the @RecordUpd@ constuctor indicates regular
@@ -124,8 +125,8 @@ type, an @Either@ instance:
@
Here,
@
-type RecUpdProj p = RecProj (LHsExpr p)
-type LHsRecUpdProj p = Located (RecUpdProj p)
+type RecUpdProj p = RecProj p (LHsExpr p)
+type LHsRecUpdProj p = XRec p (RecUpdProj p)
@
and @Left@ values indicating regular record update, @Right@ values
updates desugared to @setField@s.
@@ -140,27 +141,27 @@ values (see function @mkRdrRecordUpd@ in 'GHC.Parser.PostProcess').
type LFieldLabelStrings p = XRec p (FieldLabelStrings p)
newtype FieldLabelStrings p =
- FieldLabelStrings [Located (HsFieldLabel p)]
+ FieldLabelStrings [XRec p (DotFieldOcc p)]
-instance Outputable (FieldLabelStrings p) where
+instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where
ppr (FieldLabelStrings flds) =
- hcat (punctuate dot (map (ppr . unLoc) flds))
+ hcat (punctuate dot (map (ppr . unXRec @p) flds))
-instance OutputableBndr (FieldLabelStrings p) where
+instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where
pprInfixOcc = pprFieldLabelStrings
pprPrefixOcc = pprFieldLabelStrings
-instance OutputableBndr (Located (FieldLabelStrings p)) where
+instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where
pprInfixOcc = pprInfixOcc . unLoc
pprPrefixOcc = pprInfixOcc . unLoc
-pprFieldLabelStrings :: FieldLabelStrings p -> SDoc
+pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc
pprFieldLabelStrings (FieldLabelStrings flds) =
- hcat (punctuate dot (map (ppr . unLoc) flds))
+ hcat (punctuate dot (map (ppr . unXRec @p) flds))
-instance Outputable (HsFieldLabel p) where
- ppr (HsFieldLabel _ s) = ppr s
- ppr XHsFieldLabel{} = text "XHsFieldLabel"
+instance Outputable(XRec p FieldLabelString) => Outputable (DotFieldOcc p) where
+ ppr (DotFieldOcc _ s) = ppr s
+ ppr XDotFieldOcc{} = text "XDotFieldOcc"
-- Field projection updates (e.g. @foo.bar.baz = 1@). See Note
-- [RecordDotSyntax field updates].
@@ -534,27 +535,29 @@ data HsExpr p
-- | Record field selection e.g @z.x@.
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDot'
- --
+
+ -- For details on above see note [exact print annotations] in GHC.Parser.Annotation
+
-- This case only arises when the OverloadedRecordDot langauge
-- extension is enabled. See Note [Record Selectors in the AST].
-
| HsGetField {
gf_ext :: XGetField p
, gf_expr :: LHsExpr p
- , gf_field :: Located (HsFieldLabel p)
+ , gf_field :: XRec p (DotFieldOcc p)
}
-- | Record field selector. e.g. @(.x)@ or @(.x.y)@
--
- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenP'
- -- 'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnCloseP'
- --
-- This case only arises when the OverloadedRecordDot langauge
-- extensions is enabled. See Note [Record Selectors in the AST].
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenP'
+ -- 'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnCloseP'
+
+ -- For details on above see note [exact print annotations] in GHC.Parser.Annotation
| HsProjection {
proj_ext :: XProjection p
- , proj_flds :: [Located (HsFieldLabel p)]
+ , proj_flds :: [XRec p (DotFieldOcc p)]
}
-- | Expression with an explicit type signature. @e :: type@
@@ -669,12 +672,12 @@ type family PendingTcSplice' p
-- ---------------------------------------------------------------------
-data HsFieldLabel p
- = HsFieldLabel
- { hflExt :: XCHsFieldLabel p
- , hflLabel :: Located FieldLabelString
+data DotFieldOcc p
+ = DotFieldOcc
+ { dfoExt :: XCDotFieldOcc p
+ , dfoLabel :: XRec p FieldLabelString
}
- | XHsFieldLabel !(XXHsFieldLabel p)
+ | XDotFieldOcc !(XXDotFieldOcc p)
-- ---------------------------------------------------------------------
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 2f9b9d7583..278b8aa99e 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -427,9 +427,9 @@ type family XPragE x
type family XXExpr x
-- -------------------------------------
--- FieldLabel type families
-type family XCHsFieldLabel x
-type family XXHsFieldLabel x
+-- DotFieldOcc type families
+type family XCDotFieldOcc x
+type family XXDotFieldOcc x
-- -------------------------------------
-- HsPragE type families
View Lorry Controller Status