summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2023-04-26 18:44:24 +0100
committerAlan Zimmerman <alan.zimm@gmail.com>2023-04-26 23:28:24 +0100
commita13e2b7f192edbac6e28074a323b7dd84b3fc9f6 (patch)
tree568c5f558a937668e42f0b8155c440ca0952b60d /compiler/GHC/Tc
parent79bea00eef99495ac19bb59505fd0d701b2de439 (diff)
downloadhaskell-a13e2b7f192edbac6e28074a323b7dd84b3fc9f6.tar.gz
Put BufSpan into RealSrcSpanwip/az/locateda-epa-improve-2023-03-27
This has been superseded by !9473, which moved BufSpan into EpaSpan in EpaLocation Start on making LocatedN more direct Using EpaLocation instead of Anchor Via a synonym initially, to prove the concept Variants of AnnSortKey For future, just a list of which type comes next. Example for ValBinds EPA: Explicitly capture EOF Location in AnnsModule And also get rid of EpaEofComment.
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Deriv/Functor.hs20
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs28
-rw-r--r--compiler/GHC/Tc/Deriv/Generics.hs2
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs14
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Foreign.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Head.hs8
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Rule.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs2
-rw-r--r--compiler/GHC/Tc/Module.hs10
-rw-r--r--compiler/GHC/Tc/TyCl.hs6
-rw-r--r--compiler/GHC/Tc/TyCl/Class.hs14
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs9
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs12
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs2
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs4
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs10
-rw-r--r--compiler/GHC/Tc/Utils/Instantiate.hs2
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs38
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs8
26 files changed, 123 insertions, 104 deletions
diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index 9b5032531c..c89a0733b0 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -156,7 +156,7 @@ gen_Functor_binds loc (DerivInstTys{dit_rep_tc = tycon})
| Phantom <- last (tyConRoles tycon)
= (unitBag fmap_bind, emptyBag)
where
- fmap_name = L (noAnnSrcSpan loc) fmap_RDR
+ fmap_name = L (noAnnSrcSpanN loc) fmap_RDR
fmap_bind = mkRdrFunBind fmap_name fmap_eqns
fmap_eqns = [mkSimpleMatch fmap_match_ctxt
[nlWildPat]
@@ -168,7 +168,7 @@ gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
= (listToBag [fmap_bind, replace_bind], emptyBag)
where
data_cons = getPossibleDataCons tycon tycon_args
- fmap_name = L (noAnnSrcSpan loc) fmap_RDR
+ fmap_name = L (noAnnSrcSpanN loc) fmap_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
@@ -207,7 +207,7 @@ gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
, ft_co_var = panic "contravariant in ft_fmap" }
-- See Note [Deriving <$]
- replace_name = L (noAnnSrcSpan loc) replace_RDR
+ replace_name = L (noAnnSrcSpanN loc) replace_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
@@ -819,7 +819,7 @@ gen_Foldable_binds loc (DerivInstTys{dit_rep_tc = tycon})
| Phantom <- last (tyConRoles tycon)
= (unitBag foldMap_bind, emptyBag)
where
- foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
+ foldMap_name = L (noAnnSrcSpanN loc) foldMap_RDR
foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns
foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
[nlWildPat, nlWildPat]
@@ -837,9 +837,9 @@ gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
where
data_cons = getPossibleDataCons tycon tycon_args
- foldr_name = L (noAnnSrcSpan loc) foldable_foldr_RDR
+ foldr_name = L (noAnnSrcSpanN loc) foldable_foldr_RDR
- foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns
+ foldr_bind = mkRdrFunBind (L (noAnnSrcSpanN loc) foldable_foldr_RDR) eqns
eqns = map foldr_eqn data_cons
foldr_eqn con
= evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
@@ -847,7 +847,7 @@ gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
parts = sequence $ foldDataConArgs ft_foldr con dit
foldr_match_ctxt = mkPrefixFunRhs foldr_name
- foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
+ foldMap_name = L (noAnnSrcSpanN loc) foldMap_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)
@@ -871,7 +871,7 @@ gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
go NotNull = Nothing
go (NullM a) = Just (Just a)
- null_name = L (noAnnSrcSpan loc) null_RDR
+ null_name = L (noAnnSrcSpanN loc) null_RDR
null_match_ctxt = mkPrefixFunRhs null_name
null_bind = mkRdrFunBind null_name null_eqns
null_eqns = map null_eqn data_cons
@@ -1053,7 +1053,7 @@ gen_Traversable_binds loc (DerivInstTys{dit_rep_tc = tycon})
| Phantom <- last (tyConRoles tycon)
= (unitBag traverse_bind, emptyBag)
where
- traverse_name = L (noAnnSrcSpan loc) traverse_RDR
+ traverse_name = L (noAnnSrcSpanN loc) traverse_RDR
traverse_bind = mkRdrFunBind traverse_name traverse_eqns
traverse_eqns =
[mkSimpleMatch traverse_match_ctxt
@@ -1067,7 +1067,7 @@ gen_Traversable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
where
data_cons = getPossibleDataCons tycon tycon_args
- traverse_name = L (noAnnSrcSpan loc) traverse_RDR
+ traverse_name = L (noAnnSrcSpanN loc) traverse_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 7ada3093e5..e01b54ef22 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -601,7 +601,7 @@ nlConWildPat :: DataCon -> LPat GhcPs
-- The pattern (K {})
nlConWildPat con = noLocA $ ConPat
{ pat_con_ext = noAnn
- , pat_con = noLocA $ getRdrName con
+ , pat_con = noLocN $ getRdrName con
, pat_args = RecCon $ HsRecFields
{ rec_flds = []
, rec_dotdot = Nothing }
@@ -857,7 +857,7 @@ gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
enum_index
= mkSimpleGeneratedFunBind loc unsafeIndex_RDR
- [noLocA (AsPat noAnn (noLocA c_RDR) noHsTok
+ [noLocA (AsPat noAnn (noLocN c_RDR) noHsTok
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] (
untag_Expr [(a_RDR, ah_RDR)] (
@@ -1993,7 +1993,7 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
underlying_inst_tys :: [Type]
underlying_inst_tys = changeLast inst_tys rhs_ty
- locn = noAnnSrcSpan loc'
+ locn = noAnnSrcSpanN loc'
loca = noAnnSrcSpan loc'
-- For each class method, generate its derived binding and instance
-- signature. Using the first example from
@@ -2043,7 +2043,7 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
mk_hs_tvb (Bndr tv flag) = noLocA $ KindedTyVar noAnn
flag
- (noLocA (getRdrName tv))
+ (noLocN (getRdrName tv))
(nlHsCoreTy (tyVarKind tv))
meth_RDR = getRdrName meth_id
@@ -2081,7 +2081,7 @@ gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty
underlying_inst_tys = changeLast inst_tys rhs_ty
ats = classATs cls
- locn = noAnnSrcSpan loc'
+ locn = noAnnSrcSpanN loc'
cls_tvs = classTyVars cls
in_scope = mkInScopeSetList inst_tvs
lhs_env = zipTyEnv cls_tvs inst_tys
@@ -2167,7 +2167,7 @@ genAuxBindSpecOriginal loc spec
(genAuxBindSpecSig loc spec)))
where
loca = noAnnSrcSpan loc
- locn = noAnnSrcSpan loc
+ locn = noAnnSrcSpanN loc
gen_bind :: AuxBindSpec -> LHsBind GhcPs
gen_bind (DerivTag2Con _ tag2con_RDR)
= mkFunBindSE 0 loc tag2con_RDR
@@ -2222,7 +2222,7 @@ genAuxBindSpecDup loc original_rdr_name dup_spec
(genAuxBindSpecSig loc dup_spec)))
where
loca = noAnnSrcSpan loc
- locn = noAnnSrcSpan loc
+ locn = noAnnSrcSpanN loc
dup_rdr_name = auxBindSpecRdrName dup_spec
-- | Generate the type signature of an auxiliary binding.
@@ -2291,9 +2291,9 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindSE arity loc fun pats_and_exprs
- = mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches
+ = mkRdrFunBindSE arity (L (noAnnSrcSpanN loc) fun) matches
where
- matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
+ matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpanN loc) fun))
(map (parenthesizePat appPrec) p) e
emptyLocalBinds
| (p,e) <-pats_and_exprs]
@@ -2301,7 +2301,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 fun matches)
+ = L (l2l loc) (mkFunBind Generated 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
@@ -2312,9 +2312,9 @@ mkFunBindEC :: Arity -> SrcSpan -> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC arity loc fun catch_all pats_and_exprs
- = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches
+ = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpanN loc) fun) matches
where
- matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
+ matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpanN loc) fun))
(map (parenthesizePat appPrec) p) e
emptyLocalBinds
| (p,e) <- pats_and_exprs ]
@@ -2329,7 +2329,7 @@ mkRdrFunBindEC :: Arity
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
- = L (na2la loc) (mkFunBind Generated fun matches')
+ = L (l2l loc) (mkFunBind Generated fun matches')
where
-- Catch-all eqn looks like
-- fmap _ z = case z of {}
@@ -2353,7 +2353,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 fun matches')
+ = L (l2l loc) (mkFunBind Generated fun matches')
where
-- Catch-all eqn looks like
-- compare _ _ = error "Void compare"
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index 41e7bb3e92..7ea70157cb 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -395,7 +395,7 @@ mkBindsRep dflags gk loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)
from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ]
- loc' = noAnnSrcSpan loc
+ loc' = noAnnSrcSpanN loc
loc'' = noAnnSrcSpan loc
datacons = tyConDataCons tycon
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 33c67fee79..58da01ee7c 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -190,7 +190,7 @@ instance Diagnostic TcRnMessage where
TcRnDuplicateWarningDecls d rdr_name
-> mkSimpleDecorated $
vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
- text "also at " <+> ppr (getLocA d)]
+ text "also at " <+> ppr (getLocN d)]
TcRnSimplifierTooManyIterations simples limit wc
-> mkSimpleDecorated $
hang (text "solveWanteds: too many iterations"
@@ -307,7 +307,7 @@ instance Diagnostic TcRnMessage where
2 (vcat $ map pprLBind . bagToList $ binds)
where
pprLoc loc = parens (text "defined at" <+> ppr loc)
- pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc
+ pprLBind :: CollectPass GhcRn => LocatedAnS a (HsBindLR GhcRn idR) -> SDoc
pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)
<+> pprLoc (locA loc)
TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty
@@ -3110,7 +3110,7 @@ dodgy_msg kind tc ie
dodgy_msg_insert :: GlobalRdrElt -> IE GhcRn
dodgy_msg_insert tc_gre = IEThingAll noAnn ii
where
- ii = noLocA (IEName noExtField $ noLocA $ greName tc_gre)
+ ii = noLocA (IEName noExtField $ noLocN $ greName tc_gre)
pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc
pprTypeDoesNotHaveFixedRuntimeRep ty prov =
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index cee24aa395..95739663ac 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -219,7 +219,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 (addLocMN tcLookupConLike) ns
mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm
pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc }
doOne _ = return Nothing
@@ -609,7 +609,7 @@ tcPolyCheck prag_fn
, fun_matches = matches }))
= do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
- ; mono_name <- newNameAt (nameOccName name) (locA nm_loc)
+ ; mono_name <- newNameAt (nameOccName name) (locN nm_loc)
; (wrap_gen, (wrap_res, matches'))
<- setSrcSpan sig_loc $ -- Sets the binding location for the skolems
tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty ->
@@ -639,7 +639,7 @@ tcPolyCheck prag_fn
; poly_id <- addInlinePrags poly_id prag_sigs
; mod <- getModule
- ; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs
+ ; tick <- funBindTicks (locN nm_loc) poly_id mod prag_sigs
; let bind' = FunBind { fun_id = L nm_loc poly_id2
, fun_matches = matches'
@@ -1467,7 +1467,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name
-- Just g = ...f...
-- Hence always typechecked with InferGen
do { mono_info <- tcLhsSigId no_gen (name, sig)
- ; return (TcFunBind mono_info (locA nm_loc) matches) }
+ ; return (TcFunBind mono_info (locN nm_loc) matches) }
| otherwise -- No type signature
= do { mono_ty <- newOpenFlexiTyVarTy
@@ -1478,7 +1478,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name
; let mono_info = MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id }
- ; return (TcFunBind mono_info (locA nm_loc) matches) }
+ ; return (TcFunBind mono_info (locN nm_loc) matches) }
tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
= -- See Note [Typechecking pattern bindings]
@@ -1554,9 +1554,9 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
= tcExtendIdBinderStackForRhs [info] $
tcExtendTyVarEnvForRhs mb_sig $
do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
- ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id))
+ ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpanN loc) (idName mono_id))
matches (mkCheckExpType $ idType mono_id)
- ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
+ ; return ( FunBind { fun_id = L (noAnnSrcSpanN loc) mono_id
, fun_matches = matches'
, fun_ext = (co_fn, [])
} ) }
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index eed125e8b0..1eac073791 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -192,8 +192,8 @@ rnExports explicit_mod exports
; let real_exports
| explicit_mod = exports
| has_main
- = Just (noLocA [noLocA (IEVar noExtField
- (noLocA (IEName noExtField $ noLocA default_main)))])
+ = Just (noLocI [noLocA (IEVar noExtField
+ (noLocA (IEName noExtField $ noLocN default_main)))])
-- ToDo: the 'noLoc' here is unhelpful if 'main'
-- turns out to be out of scope
| otherwise = Nothing
@@ -532,7 +532,7 @@ lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items
do { ub <- reportUnboundName unboundName
; let l = getLoc n
gre = localVanillaGRE 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_par = par }) ->
do { checkPatSynParent spec_parent par child
; let child_nm = greName child
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 8a7ce396bf..d400a1f810 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -254,7 +254,7 @@ tcExpr e@(HsIPVar _ x) res_ty
; ipClass <- tcLookupClass ipClassName
; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
; tcWrapResult e
- (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var)))
+ (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocN ip_var)))
ip_ty res_ty }
where
-- Coerces a dictionary for `IP "x" t` into `t`.
@@ -1253,7 +1253,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr)
case_expr :: HsExpr GhcRn
- case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpan matches))
+ case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpanI matches))
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = map make_pat relevant_cons
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 31c42f86d6..ad6580b537 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -424,7 +424,7 @@ tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spe
-- We need to give a name to the new top-level binding that
-- is *stable* (i.e. the compiler won't change it later),
-- because this name will be referred to by the C code stub.
- id <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc
+ id <- mkStableIdFromName nm sig_ty (locN loc) mkForeignExportOcc
return ( mkVarBind id rhs
, ForeignExport { fd_name = L loc id
, fd_sig_ty = undefined
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index a5ad2f1733..e75f48c6a2 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -1009,7 +1009,7 @@ tcCheckId name res_ty
; addFunResCtxt rn_fun [] actual_res_ty res_ty $
tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty }
where
- rn_fun = HsVar noExtField (noLocA name)
+ rn_fun = HsVar noExtField (noLocN name)
------------------------
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
@@ -1034,7 +1034,7 @@ tc_infer_assert assert_name
= do { assert_error_id <- tcLookupId assertErrorName
; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
(idType assert_error_id)
- ; return (mkHsWrap wrap (HsVar noExtField (noLocA assert_error_id)), id_rho)
+ ; return (mkHsWrap wrap (HsVar noExtField (noLocN assert_error_id)), id_rho)
}
tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
@@ -1086,7 +1086,7 @@ tc_infer_id id_name
lcl_env <- getLocalRdrEnv
unknownNameSuggestions lcl_env WL_Anything (mkRdrUnqual occ)
- return_id id = return (HsVar noExtField (noLocA id), idType id)
+ return_id id = return (HsVar noExtField (noLocN id), idType id)
check_local_id :: Id -> TcM ()
check_local_id id
@@ -1297,7 +1297,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
; lift <- if isStringTy id_ty then
do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName
-- See Note [Lifting strings]
- ; return (HsVar noExtField (noLocA sid)) }
+ ; return (HsVar noExtField (noLocN sid)) }
else
setConstraintVar lie_var $
-- Put the 'lift' constraint into the right LIE
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 9e8375b47d..bd366d688c 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -652,7 +652,7 @@ tcDerivStrategy mb_lds
= case mb_lds of
Nothing -> boring_case Nothing
Just (L loc ds) ->
- setSrcSpanA loc $ do
+ setSrcSpanI loc $ do
(ds', tvs) <- tc_deriv_strategy ds
pure (Just (L loc ds'), tvs)
where
@@ -765,7 +765,7 @@ tcFamTyPats fam_tc hs_pats
where
fam_name = tyConName fam_tc
fam_arity = tyConArity fam_tc
- lhs_fun = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name))
+ lhs_fun = noLocA (HsTyVar noAnn NotPromoted (noLocN fam_name))
{- Note [tcFamTyPats: zonking the result kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1525,7 +1525,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/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index db48eec968..82e5b3b4d8 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -202,8 +202,8 @@ type AnnoBody body
, Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
, Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
, Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL
- , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns
- , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
+ , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnS NoEpAnns
+ , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnS NoEpAnns
, Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
, Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
)
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 28b9891b91..a728a8161d 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -415,7 +415,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
AsPat x (L nm_loc name) at pat -> do
{ mult_wrap <- checkManyPattern pat_ty
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
- ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)
+ ; (wrap, bndr_id) <- setSrcSpanN nm_loc (tcPatBndr penv name pat_ty)
; (pat', res) <- tcExtendIdEnv1 name bndr_id $
tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))
penv pat thing_inside
@@ -662,7 +662,7 @@ AST is used for the subtraction operation.
<- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $
\ [lit2_ty, var_ty] _ ->
do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
- ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
+ ; (wrap, bndr_id) <- setSrcSpanN nm_loc $
tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
-- co :: var_ty ~ idType bndr_id
@@ -906,7 +906,7 @@ tcDataConPat (L con_span con_name) data_con pat_ty_scaled
; pat_ty <- readExpType (scaledThing pat_ty_scaled)
-- Add the stupid theta
- ; setSrcSpanA con_span $ addDataConStupidTheta data_con ctxt_res_tys
+ ; setSrcSpanN con_span $ addDataConStupidTheta data_con ctxt_res_tys
-- Check that this isn't a GADT pattern match
-- in situations in which that isn't allowed.
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
index 121c43b987..fa4be02107 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ b/compiler/GHC/Tc/Gen/Rule.hs
@@ -185,7 +185,7 @@ tcRule (HsRule { rd_ext = ext
, rd_name = rname
, rd_act = act
, rd_tyvs = ty_bndrs -- preserved for ppr-ing
- , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA)
+ , rd_tmvs = map (noLocI . RuleBndr noAnn . noLocN)
(qtkvs ++ tpl_ids)
, rd_lhs = mkHsDictLet lhs_binds lhs'
, rd_rhs = mkHsDictLet rhs_binds rhs' } }
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index abd204fa50..f84e3eebfa 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -271,7 +271,7 @@ lhsSigWcTypeContextSpan (HsWC { hswc_body = sigType }) = lhsSigTypeContextSpan s
lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty
where
- go (L _ (HsQualTy { hst_ctxt = L span _ })) = WantRRC $ locA span -- Found it!
+ go (L _ (HsQualTy { hst_ctxt = L span _ })) = WantRRC $ locI span -- Found it!
go (L _ (HsForAllTy { hst_body = hs_ty })) = go hs_ty -- Look under foralls
go (L _ (HsParTy _ hs_ty)) = go hs_ty -- Look under parens
go _ = NoRRC -- Did not find it
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index e28ba6f24f..9977b867c9 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -998,7 +998,7 @@ runAnnotation target expr = do
; let loc' = noAnnSrcSpan loc
; let specialised_to_annotation_wrapper_expr
= L loc' (mkHsWrap wrapper
- (HsVar noExtField (L (noAnnSrcSpan loc) to_annotation_wrapper_id)))
+ (HsVar noExtField (L (noAnnSrcSpanN loc) to_annotation_wrapper_id)))
; return (L loc' (HsApp noComments
specialised_to_annotation_wrapper_expr expr'))
})
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 1b02340061..8cd1b5fd49 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -289,7 +289,7 @@ tcRnModuleTcRnM hsc_env mod_sum
++ import_decls))
; let { mkImport mod_name = noLocA
$ (simpleImportDecl mod_name)
- { ideclImportList = Just (Exactly, noLocA [])}}
+ { ideclImportList = Just (Exactly, noLocI [])}}
; let { withReason t imps = map (,text t) imps }
; let { all_imports = withReason "is implicitly imported" prel_imports
++ withReason "is directly imported" import_decls
@@ -2033,7 +2033,7 @@ generateMainBinding tcg_env main_name = do
{ traceTc "checkMain found" (ppr main_name)
; (io_ty, res_ty) <- getIOType
; let loc = getSrcSpan main_name
- main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name))
+ main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpanN loc) main_name))
; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $
tcCheckMonoExpr main_expr_rn io_ty
@@ -2371,7 +2371,7 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
-- Don't try to typecheck if the renamer fails!
; ghciStep <- getGhciStepIO
; uniq <- newUnique
- ; let loc' = noAnnSrcSpan $ locA loc
+ ; let loc' = noAnnSrcSpanN $ locA loc
; interPrintName <- getInteractivePrintName
; let fresh_it = itName uniq (locA loc)
matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr
@@ -2639,7 +2639,7 @@ tcGhciStmts stmts
stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)]
; return (ids, mkHsDictLet (EvBinds const_binds) $
- noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts)))
+ noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocI stmts)))
}
-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
@@ -2973,7 +2973,7 @@ tcRnLookupRdrName :: HscEnv -> LocatedN RdrName
-- ^ Find all the Names that this RdrName could mean, in GHCi
tcRnLookupRdrName hsc_env (L loc rdr_name)
= runTcInteractive hsc_env $
- setSrcSpanA loc $
+ setSrcSpanN loc $
do { -- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
-- constructor and type class identifiers.
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index de6ef49225..ee43b5937a 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -2827,7 +2827,7 @@ tcInjectivity _ Nothing
-- But this does not seem to be useful in any way so we don't do it. (Another
-- reason is that the implementation would not be straightforward.)
tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames)))
- = setSrcSpanA loc $
+ = setSrcSpanI loc $
do { let tvs = binderVars tcbs
; dflags <- getDynFlags
-- Fail eagerly to avoid reporting injectivity errors when
@@ -4346,7 +4346,7 @@ checkFieldCompat fld con1 con2 res1 res2 fty1 fty2
checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
checkValidDataCon dflags existential_ok tc con
= setSrcSpan con_loc $
- addErrCtxt (dataConCtxt (NE.singleton (L (noAnnSrcSpan con_loc) con_name))) $
+ addErrCtxt (dataConCtxt (NE.singleton (L (noAnnSrcSpanN con_loc) con_name))) $
do { let tc_tvs = tyConTyVars tc
res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
arg_tys = dataConOrigArgTys con
@@ -4992,7 +4992,7 @@ checkValidRoleAnnots role_annots tc
check_no_roles
= whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl
-checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM ()
+checkRoleAnnot :: TyVar -> LocatedAnS NoEpAnns (Maybe Role) -> Role -> TcM ()
checkRoleAnnot _ (L _ Nothing) _ = return ()
checkRoleAnnot tv (L _ (Just r1)) r2
= when (r1 /= r2) $
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 79374ac894..58d0b91d5d 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -177,7 +177,7 @@ tcClassSigs clas sigs def_methods
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))] -- AZ temp
tc_gen_sig (op_names, gen_hs_ty)
= do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
- ; return [ (op_name, (locA loc, gen_op_ty))
+ ; return [ (op_name, (locN loc, gen_op_ty))
| L loc op_name <- op_names ] }
{-
@@ -194,8 +194,8 @@ tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration
tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
= recoverM (return emptyLHsBinds) $
- setSrcSpan (getLocA class_name) $
- do { clas <- tcLookupLocatedClass (n2l class_name)
+ setSrcSpan (getLocN class_name) $
+ do { clas <- tcLookupLocatedClass 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
@@ -345,7 +345,7 @@ tcClassMinimalDef _clas sigs op_info
where
-- By default require all methods without a default implementation
defMindef :: ClassMinimalDef
- defMindef = mkAnd [ noLocA (mkVar name)
+ defMindef = mkAnd [ noLocI (mkVar name)
| (name, _, Nothing) <- op_info ]
instantiateMethod :: Class -> TcId -> [TcType] -> TcType
@@ -395,7 +395,7 @@ findMethodBind sel_name binds prag_fn
f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
| op_name == sel_name
- = Just (bind, locA bndr_loc, prags)
+ = Just (bind, locN bndr_loc, prags)
f _other = Nothing
---------------------------
@@ -508,7 +508,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
(tv', cv') = partition isTyVar tcv'
tvs' = scopedSort tv'
cvs' = scopedSort cv'
- ; rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpan loc) (tyConName fam_tc)) pat_tys'
+ ; rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpanN loc) (tyConName fam_tc)) pat_tys'
; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs'
fam_tc pat_tys' rhs'
-- NB: no validity check. We check validity of default instances
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index caae46ce36..937648d2f2 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -596,7 +596,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
-- For some reason we don't have a location for the equation
-- itself, so we make do with the location of family name
; co_ax_branch <- 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
@@ -1366,7 +1366,7 @@ addDFunPrags dfun_id sc_meth_ids
is_newtype = isNewTyCon clas_tc
wrapId :: HsWrapper -> Id -> HsExpr GhcTc
-wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocA id))
+wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocN id))
{- Note [Typechecking plan for instance declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1938,7 +1938,7 @@ tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys
mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
- ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpan bndr_loc)
+ ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpanN bndr_loc)
(idName local_meth_id) }
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
@@ -2161,7 +2161,7 @@ mkDefMethBind loc dfun_id clas sel_id dm_name
-- Copy the inline pragma (if any) from the default method
-- to this version. Note [INLINE and default methods]
- fn = noLocA (idName sel_id)
+ fn = noLocN (idName sel_id)
visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
, tyConBinderForAllTyFlag tcb /= Inferred ]
rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
@@ -2410,4 +2410,3 @@ instDeclCtxt2 dfun_ty
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = hang (text "In the instance declaration for")
2 (quotes doc)
-
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index c61c471bac..9f7e1374ba 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -768,7 +768,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, ex_tys, prov_theta, prov_dicts)
(args, arg_tys) pat_ty
- = do { let loc' = locA loc
+ = do { let loc' = locN loc
; rr_name <- newNameAt (mkTyVarOccFS (fsLit "rep")) loc'
; tv_name <- newNameAt (mkTyVarOccFS (fsLit "r")) loc'
; let rr_tv = mkTyVar rr_name runtimeRepTy
@@ -810,12 +810,12 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
body = mkLHsWrap (mkWpLet req_ev_binds) $
L (getLoc lpat) $
HsCase noExtField (nlHsVar scrutinee) $
- MG{ mg_alts = L (l2l $ getLoc lpat) cases
+ MG{ mg_alts = L (nn2la $ getLoc lpat) cases
, mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated
}
body' = noLocA $
HsLam noExtField $
- MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr
+ MG{ mg_alts = noLocI [mkSimpleMatch LambdaExpr
args body]
, mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated
}
@@ -824,7 +824,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
req_dicts body')
(EmptyLocalBinds noExtField)
mg :: MatchGroup GhcTc (LHsExpr GhcTc)
- mg = MG{ mg_alts = L (l2l $ getLoc match) [match]
+ mg = MG{ mg_alts = L (nn2la $ getLoc match) [match]
, mg_ext = MatchGroupTc [] res_ty Generated
}
matcher_arity = length req_theta + 3
@@ -958,9 +958,9 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
Unidirectional -> panic "tcPatSynBuilderBind"
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
- mk_mg body = mkMatchGroup Generated (noLocA [builder_match])
+ mk_mg body = mkMatchGroup Generated (noLocI [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/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 8e7b3b8c39..7b4367ccc5 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -876,7 +876,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
where
loc = getSrcSpan sel_name
loc' = noAnnSrcSpan loc
- locn = noAnnSrcSpan loc
+ locn = noAnnSrcSpanN loc
locc = noAnnSrcSpan loc
lbl = flLabel fl
sel_name = flSelector fl
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 5f76ba7e0c..c2e9146c1d 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -584,7 +584,7 @@ mergeSignatures
-- a signature package (i.e., does not expose any
-- modules.) If so, we can thin it.
| isFromSignaturePackage
- -> setSrcSpanA loc $ do
+ -> setSrcSpanI loc $ do
-- Suppress missing errors; they might be used to refer
-- to entities from other signatures we are merging in.
-- If an identifier truly doesn't exist in any of the
@@ -638,7 +638,7 @@ mergeSignatures
is_mod = mod_name,
is_as = mod_name,
is_qual = False,
- is_dloc = locA loc
+ is_dloc = locI loc
} ImpAll
rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just ispec) as1
setGblEnv tcg_env {
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index b8f9d83912..8a033d8e3a 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -320,11 +320,11 @@ tcLookupAxiom name = do
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
tcLookupLocatedGlobalId = addLocMA tcLookupId
-tcLookupLocatedClass :: LocatedA Name -> TcM Class
-tcLookupLocatedClass = addLocMA tcLookupClass
+tcLookupLocatedClass :: LocatedN Name -> TcM Class
+tcLookupLocatedClass = addLocMN tcLookupClass
tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
-tcLookupLocatedTyCon = addLocMA tcLookupTyCon
+tcLookupLocatedTyCon = addLocMN 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).
@@ -1074,11 +1074,11 @@ newDFunName clas tys loc
; newGlobalBinder mod dfun_occ loc }
newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name
-newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locA loc) name [tys]
+newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locN loc) name [tys]
newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name
newFamInstAxiomName (L loc name) branches
- = mk_fam_inst_name mkInstTyCoOcc (locA loc) name branches
+ = mk_fam_inst_name mkInstTyCoOcc (locN loc) name branches
mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name adaptOcc loc tc_name tyss
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 85671a0af5..58a472ff8a 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -131,7 +131,7 @@ newMethodFromName origin name ty_args
; wrap <- assert (not (isForAllTy ty) && isSingleton theta) $
instCall origin ty_args theta
- ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) }
+ ; return (mkHsWrap wrap (HsVar noExtField (noLocN id))) }
{-
************************************************************************
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 75b74cbb35..5172484ce9 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -61,9 +61,10 @@ module GHC.Tc.Utils.Monad(
addDependentFiles,
-- * Error management
- getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode,
- wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
- wrapLocMA_,wrapLocMA,
+ getSrcSpanM, setSrcSpan, setSrcSpanA, setSrcSpanI, setSrcSpanN, addLocM, addLocMA, addLocMN,
+ inGeneratedCode,
+ wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocFstMI, wrapLocSndM, wrapLocSndMA, wrapLocM_,
+ wrapLocMA_, wrapLocMA, wrapLocMI,
getErrsVar, setErrsVar,
addErr,
failWith, failAt,
@@ -993,26 +994,39 @@ setSrcSpan loc@(UnhelpfulSpan _) thing_inside
| otherwise
= thing_inside
-setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a
+setSrcSpanA :: EpAnnS ann -> TcRn a -> TcRn a
setSrcSpanA l = setSrcSpan (locA l)
+setSrcSpanI :: SrcAnn ann -> TcRn a -> TcRn a
+setSrcSpanI l = setSrcSpan (locI l)
+
+setSrcSpanN :: EpAnnS ann -> TcRn a -> TcRn a
+setSrcSpanN l = setSrcSpan (locN l)
+
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a
-addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
+addLocMA :: (a -> TcM b) -> LocatedAnS ann a -> TcM b
addLocMA fn (L loc a) = setSrcSpanA loc $ fn a
+addLocMN :: (a -> TcM b) -> LocatedN a -> TcM b
+addLocMN fn (L loc a) = setSrcSpanN 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 :: (a -> TcM b) -> LocatedAnS ann a -> TcM (Located b)
wrapLocAM fn a = wrapLocM fn (reLoc a)
-wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b)
+wrapLocMA :: (a -> TcM b) -> LocatedAnS ann a -> TcRn (LocatedAnS ann b)
wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a
; return (L loc b) }
+wrapLocMI :: (a -> TcM b) -> LocatedAn ann a -> TcRn (LocatedAn ann b)
+wrapLocMI fn (L loc a) = setSrcSpanI loc $ do { b <- fn a
+ ; return (L loc b) }
+
wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
setSrcSpan loc $ do
@@ -1024,12 +1038,18 @@ wrapLocFstM fn (L loc a) =
-- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedN a -> TcM (LocatedN b, c)
-- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c)
-- and so on.
-wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (GenLocated (SrcSpanAnn' ann) b, c)
+wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAnS ann a -> TcM (LocatedAnS ann b, c)
wrapLocFstMA fn (L loc a) =
setSrcSpanA loc $ do
(b,c) <- fn a
return (L loc b, c)
+wrapLocFstMI :: (a -> TcM (b,c)) -> GenLocated (SrcAnn ann) a -> TcM (GenLocated (SrcAnn ann) b, c)
+wrapLocFstMI fn (L loc a) =
+ setSrcSpanI loc $ do
+ (b,c) <- fn a
+ return (L loc b, c)
+
wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM fn (L loc a) =
setSrcSpan loc $ do
@@ -1041,7 +1061,7 @@ wrapLocSndM fn (L loc a) =
-- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedN a -> TcM (b, LocatedN c)
-- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAn t a -> TcM (b, LocatedAn t c)
-- and so on.
-wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (b, GenLocated (SrcSpanAnn' ann) c)
+wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAnS ann a -> TcM (b, LocatedAnS ann c)
wrapLocSndMA fn (L loc a) =
setSrcSpanA loc $ do
(b,c) <- fn a
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index aa2ffa8bae..0b667eabbb 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -669,7 +669,7 @@ zonkLTcSpecPrags env ps
************************************************************************
-}
-zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
+zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnS NoEpAnns
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
@@ -684,7 +684,7 @@ zonkMatchGroup env zBody (MG { mg_alts = L l ms
, mg_ext = MatchGroupTc arg_tys' res_ty' origin
}) }
-zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
+zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnS NoEpAnns
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> LMatch GhcTc (LocatedA (body GhcTc))
@@ -696,7 +696,7 @@ zonkMatch env zBody (L loc match@(Match { m_pats = pats
; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
-------------------------------------------------------------------------
-zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
+zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnS NoEpAnns
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> GRHSs GhcTc (LocatedA (body GhcTc))
@@ -1152,7 +1152,7 @@ zonkStmt env zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs
; new_later_rets <- mapM (zonkExpr env5) later_rets
; new_rec_rets <- mapM (zonkExpr env5) rec_rets
; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed
- RecStmt { recS_stmts = noLocA new_segStmts
+ RecStmt { recS_stmts = noLocI new_segStmts
, recS_later_ids = new_lvs
, recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
View Lorry Controller Status