From 99a6a49c91c690719f54a4f5dc88f44f514364ff Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sun, 6 Aug 2023 22:50:53 +0100
Subject: [PATCH] EPA: Clean up TC Monad Utils
We no longer need the alternative variant of addLocM (addLocMA)
nor wrapLocAM, wrapLocSndMA.
aarch64-darwin
Metric Increase:
MultiLayerModulesTH_OneShot
deb10-numa-slow
Metric Decrease:
libdir
---
compiler/GHC/Rename/Bind.hs | 2 +-
compiler/GHC/Rename/Module.hs | 8 ++++----
compiler/GHC/Tc/Gen/Bind.hs | 4 ++--
compiler/GHC/Tc/TyCl.hs | 12 ++++++------
compiler/GHC/Tc/TyCl/Class.hs | 2 +-
compiler/GHC/Tc/TyCl/Instance.hs | 2 +-
compiler/GHC/Tc/Utils/Env.hs | 10 +++++-----
compiler/GHC/Tc/Utils/Monad.hs | 23 ++++++++++-------------
8 files changed, 30 insertions(+), 33 deletions(-)
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 04c2ed97557f..4ad09c8f1663 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -459,7 +459,7 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
| isTopRecNameMaker name_maker
- = do { addLocMA checkConName rdrname
+ = do { addLocM checkConName rdrname
; name <-
lookupLocatedTopConstructorRnN rdrname -- Should be in scope already
; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index f779285d5970..15c02c06fb4c 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -276,7 +276,7 @@ rnSrcWarnDecls bndr_set decls'
; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups
in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr))
warn_rdr_dups
- ; pairs_s <- mapM (addLocMA rn_deprec) decls
+ ; pairs_s <- mapM (addLocM rn_deprec) decls
; return $ concat pairs_s }
where
decls = concatMap (wd_warnings . unLoc) decls'
@@ -1891,7 +1891,7 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond
= do { unlessXOptM LangExt.TypeData $ failWith TcRnIllegalTypeData
; unless (null (fromMaybeContext context)) $
failWith $ TcRnTypeDataForbids TypeDataForbidsDatatypeContexts
- ; mapM_ (addLocMA check_type_data_condecl) condecls
+ ; mapM_ (addLocM check_type_data_condecl) condecls
; unless (null derivs) $
failWith $ TcRnTypeDataForbids TypeDataForbidsDerivingClauses
}
@@ -2384,7 +2384,7 @@ rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
, con_mb_cxt = mcxt, con_args = args
, con_doc = mb_doc, con_forall = forall_ })
- = do { _ <- addLocMA checkConName name
+ = do { _ <- addLocM checkConName name
; new_name <- lookupLocatedTopConstructorRnN name
-- We bind no implicit binders here; this is just like
@@ -2421,7 +2421,7 @@ rnConDecl (ConDeclGADT { con_names = names
, con_g_args = args
, con_res_ty = res_ty
, con_doc = mb_doc })
- = do { mapM_ (addLocMA checkConName) names
+ = do { mapM_ (addLocM checkConName) names
; new_names <- mapM (lookupLocatedTopConstructorRnN) names
; let -- We must ensure that we extract the free tkvs in left-to-right
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 3b66d2e75ab5..958c07933818 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -223,7 +223,7 @@ tcCompleteSigs sigs =
-- compatible with the result type constructor 'mb_tc'.
doOne (L loc c@(CompleteMatchSig (_ext, _src_txt) (L _ ns) mb_tc_nm))
= fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do
- cls <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns
+ cls <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns
mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm
pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc }
doOne _ = return Nothing
@@ -239,7 +239,7 @@ tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
tcHsBootSigs binds sigs
= do { unless (null binds) $
rejectBootDecls HsBoot BootBindsRn (concatMap (bagToList . snd) binds)
- ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) }
+ ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
where
tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
where
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 554d0acde4ec..b00eaf91c525 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -1516,7 +1516,7 @@ inferInitialKinds decls
; traceTc "inferInitialKinds done }" empty
; return tcs }
where
- infer_initial_kind = addLocMA (getInitialKind InitialKindInfer)
+ infer_initial_kind = addLocM (getInitialKind InitialKindInfer)
-- Check type/class declarations against their standalone kind signatures or
-- CUSKs, producing a generalized TcTyCon for each.
@@ -1528,7 +1528,7 @@ checkInitialKinds decls
; return tcs }
where
check_initial_kind (ldecl, msig) =
- addLocMA (getInitialKind (InitialKindCheck msig)) ldecl
+ addLocM (getInitialKind (InitialKindCheck msig)) ldecl
-- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
-- depending on the 'InitialKindStrategy'.
@@ -1556,7 +1556,7 @@ getInitialKind strategy
-- See Note [Don't process associated types in getInitialKind]
; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $
- mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats
+ mapM (addLocM (getAssocFamInitialKind cls_tc)) ats
; return (cls_tc : at_tcs) }
where
getAssocFamInitialKind cls =
@@ -2621,7 +2621,7 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs
-- The (binderVars tc_bndrs) is needed bring into scope the
-- skolems bound by the class decl header (#17841)
do { ctxt <- tcHsContext hs_ctxt
- ; fds <- mapM (addLocMA tc_fundep) fundeps
+ ; fds <- mapM (addLocM tc_fundep) fundeps
; sig_stuff <- tcClassSigs class_name sigs meths
; at_stuff <- tcClassATs class_name clas ats at_defs
; return (ctxt, fds, sig_stuff, at_stuff) }
@@ -2724,7 +2724,7 @@ tcClassATs class_name cls ats at_defs
(at_def_tycon at_def) [at_def])
emptyNameEnv at_defs
- tc_at at = do { (fam_tc, val_infos) <- addLocMA (tcFamDecl1 (Just cls)) at
+ tc_at at = do { (fam_tc, val_infos) <- addLocM (tcFamDecl1 (Just cls)) at
; mapM_ (checkTyFamEqnValidityInfo fam_tc) val_infos
; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)
`orElse` []
@@ -3579,7 +3579,7 @@ tcConDecls :: DataDeclInfo
-> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon)
tcConDecls dd_info rep_tycon tmpl_bndrs res_kind
= concatMapDataDefnConsTcM (tyConName rep_tycon) $ \ new_or_data ->
- addLocMA $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon)
+ addLocM $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon)
-- mkTyConTagMap: it's important that we pay for tag allocation here,
-- once per TyCon. See Note [Constructor tag allocation], fixes #14657
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 13b4053a697c..3105419f03cb 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -237,7 +237,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
= do { -- No default method
- mapM_ (addLocMA (badDmPrag sel_id ))
+ mapM_ (addLocM (badDmPrag sel_id ))
(lookupPragEnv prag_fn (idName sel_id))
; return emptyBag }
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 4248e1a7ae9f..b41c1ff215e0 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -2425,7 +2425,7 @@ Note that
tcSpecInstPrags :: DFunId -> InstBindings GhcRn
-> TcM ([LTcSpecPrag], TcPragEnv)
tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
- = do { spec_inst_prags <- mapM (wrapLocAM (tcSpecInst dfun_id)) $
+ = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
filter isSpecInstLSig uprags
-- The filter removes the pragmas for methods
; return (spec_inst_prags, mkPragEnv uprags binds) }
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index ba45a85b87e4..b2c1003a9b0c 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -218,7 +218,7 @@ span of the Name.
tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
-- c.f. GHC.IfaceToCore.tcIfaceGlobal
tcLookupLocatedGlobal name
- = addLocMA tcLookupGlobal name
+ = addLocM tcLookupGlobal name
tcLookupGlobal :: Name -> TcM TyThing
-- The Name is almost always an ExternalName, but not always
@@ -308,13 +308,13 @@ tcLookupAxiom name = do
_ -> wrongThingErr WrongThingAxiom (AGlobal thing) name
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
-tcLookupLocatedGlobalId = addLocMA tcLookupId
+tcLookupLocatedGlobalId = addLocM tcLookupId
tcLookupLocatedClass :: LocatedA Name -> TcM Class
-tcLookupLocatedClass = addLocMA tcLookupClass
+tcLookupLocatedClass = addLocM tcLookupClass
tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
-tcLookupLocatedTyCon = addLocMA tcLookupTyCon
+tcLookupLocatedTyCon = addLocM tcLookupTyCon
-- Find the instance that exactly matches a type class application. The class arguments must be precisely
-- the same as in the instance declaration (modulo renaming & casts).
@@ -440,7 +440,7 @@ tcExtendRecEnv gbl_stuff thing_inside
-}
tcLookupLocated :: LocatedA Name -> TcM TcTyThing
-tcLookupLocated = addLocMA tcLookup
+tcLookupLocated = addLocM tcLookup
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe name
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index b03f64e7f722..112242b1092a 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -61,9 +61,9 @@ module GHC.Tc.Utils.Monad(
addDependentFiles,
-- * Error management
- getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA,
+ getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM,
inGeneratedCode, setInGeneratedCode,
- wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
+ wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
wrapLocMA_,wrapLocMA,
getErrsVar, setErrsVar,
addErr,
@@ -995,18 +995,15 @@ setInGeneratedCode thing_inside =
setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA l = setSrcSpan (locA l)
-addLocM :: (a -> TcM b) -> Located a -> TcM b
-addLocM fn (L loc a) = setSrcSpan loc $ fn a
+addLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM b
+addLocM fn (L loc a) = setSrcSpan (getHasLoc loc) $ fn a
-addLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcM b
-addLocMA fn (L loc a) = setSrcSpanA loc $ fn a
-
-wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
-wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a
- ; return (L loc b) }
-
-wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
-wrapLocAM fn a = wrapLocM fn (reLoc a)
+wrapLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM (Located b)
+wrapLocM fn (L loc a) =
+ let
+ loc' = getHasLoc loc
+ in setSrcSpan loc' $ do { b <- fn a
+ ; return (L loc' b) }
wrapLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a
--
GitLab