From db9a649693b1a1ba1d6b1ce1b86889578d2e86f8 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Wed, 1 Nov 2023 22:11:10 +0000
Subject: [PATCH] EPA: make locA a function, not a field name
And use it to generalise reLoc
The following for the windows pipeline one. 5.5%
Metric Increase:
T5205
---
compiler/GHC/Parser.y | 34 ++++++++---------
compiler/GHC/Parser/Annotation.hs | 38 +++++++++----------
compiler/GHC/Parser/PostProcess.hs | 6 +--
compiler/GHC/ThToHs.hs | 4 +-
.../should_compile/T23315/T23315.stderr | 2 -
5 files changed, 41 insertions(+), 43 deletions(-)
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index c082c493e459..1ed596b6befe 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1019,13 +1019,13 @@ exportlist1 :: { OrdList (LIE GhcPs) }
export :: { OrdList (LIE GhcPs) }
: maybe_warning_pragma qcname_ext export_subspec {% do { let { span = (maybe comb2 comb3 $1) $2 $> }
; impExp <- mkModuleImpExp $1 (fst $ unLoc $3) $2 (snd $ unLoc $3)
- ; return $ unitOL $ reLocA $ sL span $ impExp } }
+ ; return $ unitOL $ reLoc $ sL span $ impExp } }
| maybe_warning_pragma 'module' modid {% do { let { span = (maybe comb2 comb3 $1) $2 $>
; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 loc) $1) $2 }
; locImpExp <- acs (\cs -> sL span (IEModuleContents ($1, EpAnn anchor [mj AnnModule $2] cs) $3))
- ; return $ unitOL $ reLocA $ locImpExp } }
+ ; return $ unitOL $ reLoc $ locImpExp } }
| maybe_warning_pragma 'pattern' qcon { let span = (maybe comb2 comb3 $1) $2 $>
- in unitOL $ reLocA $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (glAA $2) $3)) }
+ in unitOL $ reLoc $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (glAA $2) $3)) }
export_subspec :: { Located ([AddEpAnn],ImpExpSubSpec) }
: {- empty -} { sL0 ([],ImpExpAbs) }
@@ -1117,7 +1117,7 @@ importdecl :: { LImportDecl GhcPs }
, importDeclAnnAs = fst $8
}
; let loc = (comb5 $1 $6 $7 (snd $8) $9);
- ; fmap reLocA $ acs (\cs -> L loc $
+ ; fmap reLoc $ acs (\cs -> L loc $
ImportDecl { ideclExt = XImportDeclPass (EpAnn (spanAsAnchor loc) anns cs) (snd $ fst $2) False
, ideclName = $6, ideclPkgQual = snd $5
, ideclSource = snd $2, ideclSafe = snd $3
@@ -1192,9 +1192,9 @@ importlist1 :: { OrdList (LIE GhcPs) }
| import { $1 }
import :: { OrdList (LIE GhcPs) }
- : qcname_ext export_subspec {% fmap (unitOL . reLocA . (sLL $1 $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }
- | 'module' modid {% fmap (unitOL . reLocA) $ acs (\cs -> sLL $1 $> (IEModuleContents (Nothing, EpAnn (glEE $1 $>) [mj AnnModule $1] cs) $2)) }
- | 'pattern' qcon { unitOL $ reLocA $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (glAA $1) $2)) }
+ : qcname_ext export_subspec {% fmap (unitOL . reLoc . (sLL $1 $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }
+ | 'module' modid {% fmap (unitOL . reLoc) $ acs (\cs -> sLL $1 $> (IEModuleContents (Nothing, EpAnn (glEE $1 $>) [mj AnnModule $1] cs) $2)) }
+ | 'pattern' qcon { unitOL $ reLoc $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (glAA $1) $2)) }
-----------------------------------------------------------------------------
-- Fixity Declarations
@@ -2174,7 +2174,7 @@ ctype :: { LHsType GhcPs }
, hst_xqual = NoExtField
, hst_body = $3 })) }
- | ipvar '::' ctype {% acsA (\cs -> sLL $1 $> (HsIParamTy (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) (reLocA $1) $3)) }
+ | ipvar '::' ctype {% acsA (\cs -> sLL $1 $> (HsIParamTy (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) (reLoc $1) $3)) }
| type { $1 }
----------------------
@@ -2736,7 +2736,7 @@ exp :: { ECP }
-- Embed types into expressions and patterns for required type arguments
| 'type' atype
{% do { requireExplicitNamespaces (getLoc $1)
- ; return $ ECP $ mkHsEmbTyPV (comb2 $1 (reLoc $>)) (hsTok $1) $2 } }
+ ; return $ ECP $ mkHsEmbTyPV (comb2 $1 $>) (hsTok $1) $2 } }
infixexp :: { ECP }
: exp10 { $1 }
@@ -2998,7 +2998,7 @@ aexp2 :: { ECP }
-- Template Haskell Extension
| splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }
- | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA $1) }
+ | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLoc $1) }
| SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
| SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
@@ -3036,8 +3036,8 @@ projection
| PREFIX_PROJ field {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glEE $1 $>) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }
splice_exp :: { LHsExpr GhcPs }
- : splice_untyped { fmap (HsUntypedSplice noAnn) (reLocA $1) }
- | splice_typed { fmap (uncurry HsTypedSplice) (reLocA $1) }
+ : splice_untyped { fmap (HsUntypedSplice noAnn) (reLoc $1) }
+ | splice_typed { fmap (uncurry HsTypedSplice) (reLoc $1) }
splice_untyped :: { Located (HsUntypedSplice GhcPs) }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
@@ -3338,7 +3338,7 @@ alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }
ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }
: '->' exp { unECP $2 >>= \ $2 ->
- acs (\cs -> sLL $1 $> (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 (reLoc $2)) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 (reLoc $2)) $2)) }
+ acs (\cs -> sLL $1 $> (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 $2) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 $2) $2)) }
| gdpats { $1 >>= \gdpats ->
return $ sL1 gdpats (reverse (unLoc gdpats)) }
@@ -3535,7 +3535,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- reversed
dbind :: { LIPBind GhcPs }
dbind : ipvar '=' exp {% runPV (unECP $3) >>= \ $3 ->
- acsA (\cs -> sLL $1 $> (IPBind (EpAnn (glEE $1 $>) [mj AnnEqual $2] cs) (reLocA $1) $3)) }
+ acsA (\cs -> sLL $1 $> (IPBind (EpAnn (glEE $1 $>) [mj AnnEqual $2] cs) (reLoc $1) $3)) }
ipvar :: { Located HsIPName }
: IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
@@ -4361,7 +4361,7 @@ acsa a = do
return (a cs)
acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)
-acsA a = reLocA <$> acs a
+acsA a = reLoc <$> acs a
acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP
acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a
@@ -4421,7 +4421,7 @@ mcs ll = mj AnnCloseS ll
pvA :: MonadP m => m (Located a) -> m (LocatedAn t a)
pvA a = do { av <- a
- ; return (reLocA av) }
+ ; return (reLoc av) }
pvN :: MonadP m => m (Located a) -> m (LocatedN a)
pvN a = do { (L l av) <- a
@@ -4475,7 +4475,7 @@ hsDoAnn (L l _) (L ll _) kw
listAsAnchor :: [LocatedAn t a] -> Located b -> Anchor
listAsAnchor [] (L l _) = spanAsAnchor l
-listAsAnchor (h:_) s = spanAsAnchor (comb2 (reLoc h) s)
+listAsAnchor (h:_) s = spanAsAnchor (comb2 h s)
listAsAnchorM :: [LocatedAn t a] -> Maybe Anchor
listAsAnchorM [] = Nothing
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 65ccdfff07fd..34738e30a99f 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -51,7 +51,7 @@ module GHC.Parser.Annotation (
-- ** Utilities for converting between different 'GenLocated' when
-- ** we do not care about the annotations.
la2na, na2la, n2l, l2n, l2l, la2la,
- reLoc, reLocA, reLocL, reLocC, reLocN,
+ reLoc,
HasLoc(..), getHasLocList,
srcSpan2e, la2e, realSrcSpan,
@@ -78,6 +78,7 @@ module GHC.Parser.Annotation (
-- ** Constructing 'GenLocated' annotation types when we do not care
-- about annotations.
HasAnnotation(..),
+ locA,
noLocA,
getLocA,
noSrcSpanA,
@@ -579,7 +580,7 @@ emptyComments = EpaComments []
-- Important that the fields are strict as these live inside L nodes which
-- are live for a long time.
-data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locA :: !SrcSpan }
+data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locAn :: !SrcSpan }
deriving (Data, Eq)
-- See Note [XRec and Anno in the AST]
@@ -1016,27 +1017,23 @@ l2l l = SrcSpanAnn EpAnnNotUsed (locA l)
na2la :: (NoAnn ann) => SrcSpanAnn' a -> SrcAnn ann
na2la l = noAnnSrcSpan (locA l)
-reLoc :: LocatedAn a e -> Located e
-reLoc (L (SrcSpanAnn _ l) a) = L l a
+locA :: (HasLoc a) => a -> SrcSpan
+locA = getHasLoc
-reLocA :: Located e -> LocatedAn ann e
-reLocA (L l a) = (L (SrcSpanAnn EpAnnNotUsed l) a)
+reLoc :: (HasLoc (GenLocated a e), HasAnnotation b)
+ => GenLocated a e -> GenLocated b e
+reLoc (L la a) = L (noAnnSrcSpan $ locA (L la a) ) a
-reLocL :: LocatedN e -> LocatedA e
-reLocL (L l a) = (L (na2la l) a)
-
-reLocC :: LocatedN e -> LocatedC e
-reLocC (L l a) = (L (na2la l) a)
-
-reLocN :: LocatedN a -> Located a
-reLocN (L (SrcSpanAnn _ l) a) = L l a
-- ---------------------------------------------------------------------
class HasAnnotation e where
noAnnSrcSpan :: SrcSpan -> e
-instance (NoAnn ann) => HasAnnotation (SrcSpanAnn' (EpAnn ann)) where
+instance HasAnnotation (SrcSpan) where
+ noAnnSrcSpan l = l
+
+instance HasAnnotation (SrcSpanAnn' (EpAnn ann)) where
noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l
noLocA :: (HasAnnotation e) => a -> GenLocated e a
@@ -1060,11 +1057,14 @@ class HasLoc a where
-- ^ conveniently calculate locations for things without locations attached
getHasLoc :: a -> SrcSpan
-instance HasLoc (Located a) where
- getHasLoc (L l _) = l
+instance (HasLoc l) => HasLoc (GenLocated l a) where
+ getHasLoc (L l _) = getHasLoc l
+
+instance HasLoc SrcSpan where
+ getHasLoc l = l
-instance HasLoc (GenLocated (SrcSpanAnn' a) e) where
- getHasLoc (L (SrcSpanAnn _ l) _) = l
+instance HasLoc (SrcSpanAnn' a) where
+ getHasLoc (SrcSpanAnn _ l) = l
instance (HasLoc a) => (HasLoc (Maybe a)) where
getHasLoc (Just a) = getHasLoc a
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 468214adb8c3..225541512f05 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1727,7 +1727,7 @@ instance DisambECP (HsCmd GhcPs) where
mkHsOpAppPV l c1 op c2 = do
let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c
cs <- getCommentsFor l
- return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2]
+ return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLoc op) Infix Nothing [cmdArg c1, cmdArg c2]
mkHsCasePV l c (L lm m) anns = do
cs <- getCommentsFor l
@@ -1807,7 +1807,7 @@ instance DisambECP (HsExpr GhcPs) where
superInfixOp m = m
mkHsOpAppPV l e1 op e2 = do
cs <- getCommentsFor l
- return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLocL op) e2
+ return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLoc op) e2
mkHsCasePV l e (L lm m) anns = do
cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
@@ -2092,7 +2092,7 @@ instance DisambTD DataConBuilder where
= -- When the user writes data T = {-# UNPACK #-} Int :+ Bool
-- we apply {-# UNPACK #-} to the LHS
do lhs' <- addUnpackednessP unpk lhs
- let l = combineLocsA (reLocA unpk) constr_stuff
+ let l = combineLocsA (reLoc unpk) constr_stuff
return $ L l (InfixDataConBuilder lhs' data_con rhs)
| otherwise =
do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 4abbec364765..e47bbeff4dbb 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1016,7 +1016,7 @@ cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind n e = do
n' <- wrapL (ipName n)
e' <- cvtl e
- returnLA (IPBind noAnn (reLocA n') e')
+ returnLA (IPBind noAnn (reLoc n') e')
-------------------------------------------------------------------
-- Expressions
@@ -1799,7 +1799,7 @@ cvtTypeKind typeOrKind ty
ImplicitParamT n t
-> do { n' <- wrapL $ ipName n
; t' <- cvtType t
- ; returnLA (HsIParamTy noAnn (reLocA n') t')
+ ; returnLA (HsIParamTy noAnn (reLoc n') t')
}
_ -> failWith (MalformedType typeOrKind ty)
diff --git a/testsuite/tests/parser/should_compile/T23315/T23315.stderr b/testsuite/tests/parser/should_compile/T23315/T23315.stderr
index 4a4f2637d9bb..ea75800b6e01 100644
--- a/testsuite/tests/parser/should_compile/T23315/T23315.stderr
+++ b/testsuite/tests/parser/should_compile/T23315/T23315.stderr
@@ -108,5 +108,3 @@
" More docs"))
[]))
[])))))]))
-
-
--
GitLab