summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
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.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs14
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs2
-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.hs12
-rw-r--r--compiler/GHC/Tc/Gen/HsType.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/Splice.hs2
-rw-r--r--compiler/GHC/Tc/Module.hs6
-rw-r--r--compiler/GHC/Tc/TyCl.hs2
-rw-r--r--compiler/GHC/Tc/TyCl/Class.hs10
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs8
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs6
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs2
-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.hs15
22 files changed, 87 insertions, 76 deletions
diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index 4b111f7a41..b69ab23211 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 e51eee9841..ddbf5be91e 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -598,7 +598,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 }
@@ -854,7 +854,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)] (
@@ -1990,7 +1990,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
@@ -2040,7 +2040,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
@@ -2078,7 +2078,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
@@ -2164,7 +2164,7 @@ genAuxBindSpecOriginal dflags 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
@@ -2220,7 +2220,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.
@@ -2289,9 +2289,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]
@@ -2299,7 +2299,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 (nn2la 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
@@ -2310,9 +2310,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 ]
@@ -2327,7 +2327,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 (nn2la loc) (mkFunBind Generated fun matches')
where
-- Catch-all eqn looks like
-- fmap _ z = case z of {}
@@ -2351,7 +2351,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 (nn2la 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 d35bac99a4..26e6e30c29 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -388,7 +388,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 0c152b27b7..123fe5106c 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -168,7 +168,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"
@@ -1837,7 +1837,7 @@ dodgy_msg_insert :: forall p . (Anno (IdP (GhcPass p)) ~ SrcSpanAnnN) => IdP (Gh
dodgy_msg_insert tc = IEThingAll noAnn ii
where
ii :: LIEWrappedName (GhcPass p)
- ii = noLocA (IEName noExtField $ noLocA tc)
+ ii = noLocA (IEName noExtField $ noLocN tc)
pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc
pprTypeDoesNotHaveFixedRuntimeRep ty prov =
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 10e665051d..543bb2f472 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -211,7 +211,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
@@ -601,7 +601,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 ->
@@ -631,7 +631,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'
@@ -1437,7 +1437,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
@@ -1448,7 +1448,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]
@@ -1524,9 +1524,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) mono_id)
+ ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpanN loc) 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 d42ee046b5..10830b9cd5 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -190,7 +190,7 @@ rnExports explicit_mod exports
| explicit_mod = exports
| has_main
= Just (noLocA [noLocA (IEVar noExtField
- (noLocA (IEName noExtField $ noLocA default_main)))])
+ (noLocA (IEName noExtField $ noLocN default_main)))])
-- ToDo: the 'noLoc' here is unhelpful if 'main'
-- turns out to be out of scope
| otherwise = Nothing
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index c2a680b3d4..aaf5a4ced7 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -255,7 +255,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`.
@@ -1520,7 +1520,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
; return $ L l HsFieldBind
{ hfbAnn = hfbAnn upd
, hfbLHS
- = L (l2l loc) (Unambiguous i (L (l2l loc) lbl))
+ = L (l2l loc) (Unambiguous i (L (l2ln loc) lbl))
, hfbRHS = hfbRHS upd
, hfbPun = hfbPun upd
}
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index b8899e2431..570e580b59 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -402,7 +402,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 b01c7ccb5d..83e0e51b81 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -1007,11 +1007,11 @@ tcInferOverLit lit@(OverLit { ol_val = val
(1, []) from_ty
; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)
- ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $
+ ; let lit_expr = L (nn2la loc) $ mkHsWrapCo co $
HsLit noAnn hs_lit
from_expr = mkHsWrap (wrap2 <.> wrap1) $
HsVar noExtField (L loc from_id)
- witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr
+ witness = HsApp noAnn (L (nn2la loc) from_expr) lit_expr
lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable
, ol_witness = witness
, ol_type = res_ty } }
@@ -1030,7 +1030,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)
@@ -1055,7 +1055,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)
@@ -1113,7 +1113,7 @@ tc_infer_id id_name
return $ unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env
lcl_env imp_info (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
@@ -1324,7 +1324,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 19ea11f2d4..21c542c6c0 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -759,7 +759,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1516,7 +1516,7 @@ splitHsAppTys hs_ty
go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l 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 (nn2la sp) (HsTyVar noAnn prom op)
, HsValArg l : HsValArg r : as )
go f as = (f, as)
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index c82a6ac1b5..01695e75ee 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -406,7 +406,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
@@ -653,7 +653,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
@@ -898,7 +898,7 @@ tcDataConPat penv (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 38572d7341..8e8914a55f 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ b/compiler/GHC/Tc/Gen/Rule.hs
@@ -182,7 +182,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 (noLocA . 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/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index c856523f4f..f15a275617 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1008,7 +1008,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 a38977b91e..ebd2ff8fad 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -1911,7 +1911,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
@@ -2247,7 +2247,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
@@ -2842,7 +2842,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 ac5e336e65..8bd807379c 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -4350,7 +4350,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
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 4cb0e9d2c0..405d2137bc 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -173,7 +173,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 ] }
{-
@@ -190,8 +190,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
@@ -391,7 +391,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
---------------------------
@@ -504,7 +504,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 8b3c34aa83..02e8f93891 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -597,7 +597,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 (nn2la $ getLoc fam_lname) eqn)
-- (2) check for validity
; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
@@ -1371,7 +1371,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1889,7 +1889,7 @@ tcMethodBody 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
@@ -2120,7 +2120,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
, tyConBinderArgFlag tcb /= Inferred ]
rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 2e9b3c1809..b86878dee6 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -786,7 +786,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 (mkTyVarOcc "rep") loc'
; tv_name <- newNameAt (mkTyVarOcc "r") loc'
; let rr_tv = mkTyVar rr_name runtimeRepTy
@@ -982,7 +982,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 (noLocA [builder_match])
where
- builder_args = [L (na2la loc) (VarPat noExtField (L loc n))
+ builder_args = [L (nn2la loc) (VarPat noExtField (L loc n))
| L loc n <- args]
builder_match = mkMatch (mkPrefixFunRhs ps_lname)
builder_args body
@@ -1039,7 +1039,7 @@ tcPatToExpr name args pat = go pat
-> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr lcon@(L loc _) pats
= do { exprs <- mapM go pats
- ; let con = L (l2l loc) (HsVar noExtField lcon)
+ ; let con = L (nn2la loc) (HsVar noExtField lcon)
; return (unLoc $ mkHsApps con exprs)
}
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index e071a7c7a2..5f5b2d3922 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -889,7 +889,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/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 5f73a56724..450ccd1245 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -314,11 +314,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).
@@ -1082,11 +1082,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 6aa02e4788..0bf4350053 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -132,7 +132,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 272701b6c3..9f1626ef90 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,
+ getSrcSpanM, setSrcSpan, setSrcSpanA, setSrcSpanN, addLocM, addLocMA, addLocMN,
+ inGeneratedCode,
wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
- wrapLocMA_,wrapLocMA,
+ wrapLocMA_, wrapLocMA, wrapLocMN,
getErrsVar, setErrsVar,
addErr,
failWith, failAt,
@@ -987,12 +988,18 @@ setSrcSpan loc@(UnhelpfulSpan _) thing_inside
setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA l = setSrcSpan (locA 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 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) }
@@ -1004,6 +1011,10 @@ wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated
wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a
; return (L loc b) }
+wrapLocMN :: (a -> TcM b) -> LocatedN a -> TcRn (LocatedN b)
+wrapLocMN fn (L loc a) = setSrcSpanN 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
View Lorry Controller Status