From 8217acb8afe883659cdf6e9ccf7a3d6f943f8082 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sat, 29 Jul 2023 18:39:53 +0100
Subject: [PATCH] EPA: get rid of l2l and friends
Replace them with
l2l to convert the location
la2la to convert a GenLocated thing
Updates haddock submodule
---
compiler/GHC/Parser.y | 3 +++
compiler/GHC/Parser/Annotation.hs | 30 +++++++-----------------------
compiler/GHC/Parser/PostProcess.hs | 4 ++--
compiler/GHC/Rename/Expr.hs | 4 ++--
compiler/GHC/Rename/Module.hs | 2 +-
compiler/GHC/Rename/Names.hs | 18 +++++++++---------
compiler/GHC/Rename/Pat.hs | 2 +-
compiler/GHC/Rename/Splice.hs | 4 ++--
compiler/GHC/Runtime/Eval.hs | 2 +-
compiler/GHC/Tc/Deriv/Generate.hs | 6 +++---
compiler/GHC/Tc/Gen/Export.hs | 2 +-
compiler/GHC/Tc/Gen/HsType.hs | 2 +-
compiler/GHC/Tc/TyCl/Class.hs | 4 ++--
compiler/GHC/Tc/TyCl/Instance.hs | 2 +-
compiler/GHC/Tc/TyCl/PatSyn.hs | 2 +-
utils/haddock | 2 +-
16 files changed, 38 insertions(+), 51 deletions(-)
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 1ed596b6befe..7f0ce0de1174 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -4332,6 +4332,9 @@ glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor
glNRR :: LocatedN a -> EpaLocation
glNRR = srcSpan2e . getLocA
+n2l :: LocatedN a -> LocatedA a
+n2l (L la a) = L (l2l la) a
+
anc :: RealSrcSpan -> Anchor
anc r = Anchor r UnchangedAnchor
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 34738e30a99f..fc4a918689af 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -50,7 +50,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,
+ l2l, la2la,
reLoc,
HasLoc(..), getHasLocList,
@@ -991,31 +991,15 @@ knowing that in most cases the original list is empty.
-- ---------------------------------------------------------------------
--- |Helper function (temporary) during transition of names
+-- |Helper function for converting annotation types.
-- Discards any annotations
-l2n :: LocatedAn a1 a2 -> LocatedN a2
-l2n (L la a) = L (noAnnSrcSpan (locA la)) a
+l2l :: (HasLoc a, HasAnnotation b) => a -> b
+l2l a = noAnnSrcSpan (getHasLoc a)
-n2l :: LocatedN a -> LocatedA a
-n2l (L la a) = L (na2la la) a
-
--- |Helper function (temporary) during transition of names
--- Discards any annotations
-la2na :: SrcSpanAnn' a -> SrcSpanAnnN
-la2na l = noAnnSrcSpan (locA l)
-
--- |Helper function (temporary) during transition of names
--- Discards any annotations
-la2la :: (NoAnn ann2) => LocatedAn ann1 a2 -> LocatedAn ann2 a2
-la2la (L la a) = L (noAnnSrcSpan (locA la)) a
-
-l2l :: SrcSpanAnn' a -> SrcAnn ann
-l2l l = SrcSpanAnn EpAnnNotUsed (locA l)
-
--- |Helper function (temporary) during transition of names
+-- |Helper function for converting annotation types.
-- Discards any annotations
-na2la :: (NoAnn ann) => SrcSpanAnn' a -> SrcAnn ann
-na2la l = noAnnSrcSpan (locA l)
+la2la :: (HasLoc l, HasAnnotation l2) => GenLocated l a -> GenLocated l2 a
+la2la (L la a) = L (noAnnSrcSpan (getHasLoc la)) a
locA :: (HasLoc a) => a -> SrcSpan
locA = getHasLoc
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 225541512f05..4df1e38830bd 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1837,7 +1837,7 @@ instance DisambECP (HsExpr GhcPs) where
mkHsParPV l lpar e rpar = do
cs <- getCommentsFor l
return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar)
- mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v)
+ mkHsVarPV v@(L l _) = return $ L (l2l l) (HsVar noExtField v)
mkHsLitPV (L l a) = do
cs <- getCommentsFor l
return $ L l (HsLit (comment (realSrcSpan l) cs) a)
@@ -1912,7 +1912,7 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
- mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)
+ mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
checkUnboxedLitPat lit
return $ L l (PatBuilderPat (LitPat noExtField a))
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index ffd8152c9c55..8a2fb766fd6e 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -244,7 +244,7 @@ finishHsVar (L l name)
= do { this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalName name
- ; return (HsVar noExtField (L (la2na l) name), unitFV name) }
+ ; return (HsVar noExtField (L (l2l l) name), unitFV name) }
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar v = do
@@ -280,7 +280,7 @@ rnExpr (HsVar _ (L l v))
-> rnExpr (ExplicitList noAnn [])
| otherwise
- -> finishHsVar (L (na2la l) nm)
+ -> finishHsVar (L (l2l l) nm)
}}}
rnExpr (HsIPVar x v)
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index ecf1a3250a41..6caa6417bbd5 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -2539,7 +2539,7 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do {
return ((PatSynName bnd_name, con_info) : names)
| L bind_loc (PatSynBind _ (PSB { psb_id = L _ n, psb_args = as })) <- bind
= do
- bnd_name <- newTopSrcBinder (L (la2na bind_loc) n)
+ bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)
let con_info = mkConInfo (conDetailsArity length as) []
return ((PatSynName bnd_name, con_info) : names)
| otherwise
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 99d4f6c2c50f..ad5e6f4e9a9a 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -869,10 +869,10 @@ getLocalNonValBinders fixity_env
new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances
= do { let TyDeclBinders (main_bndr, tc_flav) at_bndrs sig_bndrs
(LConsWithFields cons_with_flds flds) = hsLTyClDeclBinders tc_decl
- ; tycon_name <- newTopSrcBinder $ l2n main_bndr
- ; at_names <- mapM (newTopSrcBinder . l2n . fst) at_bndrs
- ; sig_names <- mapM (newTopSrcBinder . l2n) sig_bndrs
- ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds
+ ; tycon_name <- newTopSrcBinder $ la2la main_bndr
+ ; at_names <- mapM (newTopSrcBinder . la2la . fst) at_bndrs
+ ; sig_names <- mapM (newTopSrcBinder . la2la) sig_bndrs
+ ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds
; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst con_names_with_flds) flds
; mapM_ (add_dup_fld_errs flds') con_names_with_flds
; let tc_gre = mkLocalTyConGRE (fmap (const tycon_name) tc_flav) tycon_name
@@ -947,7 +947,7 @@ getLocalNonValBinders fixity_env
new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl })
= do { main_name <- unLoc <$> lookupFamInstName mb_cls (feqn_tycon ti_decl)
; let LConsWithFields cons_with_flds flds = hsDataFamInstBinders dfid
- ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds
+ ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds
; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst sub_names) flds
; mapM_ (add_dup_fld_errs flds') sub_names
; let fld_env = mk_fld_env sub_names flds'
@@ -2133,14 +2133,14 @@ printMinimalImports hsc_src imports_w_usage
to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
to_ie_post_rn_var (L l n)
- | isDataOcc $ occName n = L l (IEPattern (la2e l) (L (la2na l) n))
- | otherwise = L l (IEName noExtField (L (la2na l) n))
+ | isDataOcc $ occName n = L l (IEPattern (la2e l) (L (l2l l) n))
+ | otherwise = L l (IEName noExtField (L (l2l l) n))
to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
to_ie_post_rn (L l n)
- | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l) (L (la2na l) n))
- | otherwise = L l (IEName noExtField (L (la2na l) n))
+ | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l) (L (l2l l) n))
+ | otherwise = L l (IEName noExtField (L (l2l l) n))
where occ = occName n
{-
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 81b3b3b19ad2..b563a3ebf4fd 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -558,7 +558,7 @@ rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
; return (NPat x (L l lit') mb_neg' eq') }
rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ )
- = do { new_name <- newPatName mk (l2n rdr)
+ = do { new_name <- newPatName mk (la2la rdr)
; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
-- We skip negateName as
-- negative zero doesn't make
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 621f1ee00831..2d7af155f025 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -391,12 +391,12 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name
mkQuasiQuoteExpr flavour quoter (L q_span' quote)
= L q_span $ HsApp noComments (L q_span
$ HsApp noComments (L q_span
- (HsVar noExtField (L (la2na q_span) quote_selector)))
+ (HsVar noExtField (L (l2l q_span) quote_selector)))
quoterExpr)
quoteExpr
where
q_span = noAnnSrcSpan (locA q_span')
- quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter)
+ quoterExpr = L q_span $! HsVar noExtField $! (L (l2l q_span) quoter)
quoteExpr = L q_span $! HsLit noComments $! HsString NoSourceText quote
quote_selector = case flavour of
UntypedExpSplice -> quoteExpName
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 7d1a034a26c1..0024d5bc42f6 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -1241,7 +1241,7 @@ dynCompileExpr expr = do
parsed_expr <- parseExpr expr
-- > Data.Dynamic.toDyn expr
let loc = getLoc parsed_expr
- to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (la2na loc) $ getRdrName toDynName)
+ to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (l2l loc) $ getRdrName toDynName)
parsed_expr
hval <- compileParsedExpr to_dyn_expr
return (unsafeCoerce hval :: Dynamic)
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 8b6d08cf2f79..917a48ae2092 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -2292,7 +2292,7 @@ mkFunBindSE arity loc fun pats_and_exprs
mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBind fun@(L loc _fun_rdr) matches
- = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches)
+ = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches)
-- | Make a function binding. If no equations are given, produce a function
-- with the given arity that uses an empty case expression for the last
@@ -2320,7 +2320,7 @@ mkRdrFunBindEC :: Arity
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
- = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches')
+ = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches')
where
-- Catch-all eqn looks like
-- fmap _ z = case z of {}
@@ -2344,7 +2344,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
- = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches')
+ = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches')
where
-- Catch-all eqn looks like
-- compare _ _ = error "Void compare"
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index c189dcc140dd..2ed30cbe123d 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -710,7 +710,7 @@ lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items
do { ub <- reportUnboundName unboundName
; let l = getLoc n
gre = mkLocalGRE UnboundGRE NoParent ub
- ; return (L l (IEName noExtField (L (la2na l) ub)), gre)}
+ ; return (L l (IEName noExtField (L (l2l l) ub)), gre)}
FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) ->
do { checkPatSynParent spec_parent par child_nm
; return (replaceLWrappedName n child_nm, child)
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 6f1d9545d236..5ffe4d35526e 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -1542,7 +1542,7 @@ splitHsAppTys hs_ty
go (L _ (HsAppKindTy _ ty at k)) as = go ty (HsTypeArg at k : as)
go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as)
go (L _ (HsOpTy _ prom l op@(L sp _) r)) as
- = ( L (na2la sp) (HsTyVar noAnn prom op)
+ = ( L (l2l sp) (HsTyVar noAnn prom op)
, HsValArg l : HsValArg r : as )
go f as = (f, as)
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 10d39cc48d9b..13b4053a697c 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -195,7 +195,7 @@ tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
= recoverM (return emptyLHsBinds) $
setSrcSpan (getLocA class_name) $
- do { clas <- tcLookupLocatedClass (n2l class_name)
+ do { clas <- tcLookupLocatedClass (la2la class_name)
-- We make a separate binding for each default method.
-- At one time I used a single AbsBinds for all of them, thus
@@ -281,7 +281,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
- lm_bind = dm_bind { fun_id = L (la2na bind_loc) local_dm_name }
+ lm_bind = dm_bind { fun_id = L (l2l bind_loc) local_dm_name }
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 505899d47450..bae9b0fb85d1 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -610,7 +610,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
-- itself, so we make do with the location of family name
; (co_ax_branch, co_ax_validity_info)
<- tcTyFamInstEqn fam_tc mb_clsinfo
- (L (na2la $ getLoc fam_lname) eqn)
+ (L (l2l $ getLoc fam_lname) eqn)
-- (2) check for validity
; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 14e56b298f9d..d26b7d1cdf1c 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -943,7 +943,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg body = mkMatchGroup (Generated SkipPmc) (noLocA [builder_match])
where
- builder_args = [L (na2la loc) (VarPat noExtField (L loc n))
+ builder_args = [L (l2l loc) (VarPat noExtField (L loc n))
| L loc n <- args]
builder_match = mkMatch (mkPrefixFunRhs ps_lname)
builder_args body
diff --git a/utils/haddock b/utils/haddock
index b75ff8a88bbd..2cbf7f0a5589 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit b75ff8a88bbdd0d60032a4e304d37ec65526c06b
+Subproject commit 2cbf7f0a55898e0c2827ae9ad13727b34877e793
--
GitLab