summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc/Gen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc/Gen')
-rw-r--r--compiler/GHC/Tc/Gen/Arrow.hs8
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs14
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Rule.hs2
6 files changed, 16 insertions, 18 deletions
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index fa6b5ba4c2..da8bf7901f 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -98,7 +98,7 @@ tcProc pat cmd@(L loc (HsCmdTop names _)) exp_ty
; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
-- start with the names as they are used to desugar the proc itself
-- See #17423
- ; names' <- setSrcSpan loc $
+ ; names' <- setSrcSpanA loc $
mapM (tcSyntaxName ProcOrigin arr_ty) names
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
; (pat', cmd') <- newArrowScope
@@ -136,7 +136,7 @@ tcCmdTop :: CmdEnv
-> TcM (LHsCmdTop GhcTc)
tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)
- = setSrcSpan loc $
+ = setSrcSpanA loc $
do { cmd' <- tcCmd env cmd cmd_ty
; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }
@@ -301,7 +301,7 @@ tc_cmd env
tc_grhss (GRHSs x grhss binds) stk_ty res_ty
= do { (binds', grhss') <- tcLocalBinds binds $
- mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss
+ mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss
; return (GRHSs x grhss' binds') }
tc_grhs stk_ty res_ty (GRHS x guards body)
@@ -349,7 +349,7 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
= do { arr_ty <- newFlexiTyVarTy arrowTyConKind
; stk_ty <- newFlexiTyVarTy liftedTypeKind
; res_ty <- newFlexiTyVarTy liftedTypeKind
- ; names' <- setSrcSpan loc $
+ ; names' <- setSrcSpanA loc $
mapM (tcSyntaxName ArrowCmdOrigin arr_ty) names
; let env' = env { cmd_arr = arr_ty }
; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 87d8560fab..c9e9129251 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -406,7 +406,7 @@ tcExpr (HsIf x pred b1 b2) res_ty
; return (HsIf x pred' b1' b2') }
tcExpr (HsMultiIf _ alts) res_ty
- = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
+ = do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts
; res_ty <- readExpType res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
@@ -1269,7 +1269,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
-- (giving duplicate deprecation warnings).
Just gre -> do { unless (null (tail xs)) $ do
let L loc _ = hfbLHS (unLoc upd)
- setSrcSpan loc $ addUsedGRE True gre
+ setSrcSpanA loc $ addUsedGRE True gre
; lookupSelector (upd, greMangledName gre) }
-- The field doesn't belong to this parent, so report
-- an error but keep going through all the fields
@@ -1285,12 +1285,10 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
= do { i <- tcLookupId n
; let L loc af = hfbLHS upd
lbl = rdrNameAmbiguousFieldOcc af
- -- ; return $ L l upd { hfbLHS
- -- = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) }
; return $ L l HsFieldBind
{ hfbAnn = hfbAnn upd
, hfbLHS
- = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl))
+ = L (l2l loc) (Unambiguous i (L (l2l loc) lbl))
, hfbRHS = hfbRHS upd
, hfbPun = hfbPun upd
}
@@ -1368,7 +1366,7 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
, hfbRHS = rhs }))
= do { let lbl = rdrNameAmbiguousFieldOcc af
sel_id = selectorAmbiguousFieldOcc af
- f = L loc (FieldOcc (idName sel_id) (L (noAnnSrcSpan loc) lbl))
+ f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl))
; mb <- tcRecordField con_like flds_w_tys f rhs
; case mb of
Nothing -> return Nothing
@@ -1377,7 +1375,7 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
(L l (fld { hfbLHS
= L loc (Unambiguous
(foExt (unLoc f'))
- (L (noAnnSrcSpan loc) lbl))
+ (L (l2l loc) lbl))
, hfbRHS = rhs' }))) }
tcRecordField :: ConLike -> Assoc Name Type
@@ -1392,7 +1390,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
field_ty
; let field_id = mkUserLocal (nameOccName sel_name)
(nameUnique sel_name)
- Many field_ty loc
+ Many field_ty (locA loc)
-- Yuk: the field_id has the *unique* of the selector Id
-- (so we can find it easily)
-- but is a LocalId with the appropriate type of the RHS
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 6f01091200..3c502c557d 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -641,7 +641,7 @@ tcDerivStrategy mb_lds
= case mb_lds of
Nothing -> boring_case Nothing
Just (L loc ds) ->
- setSrcSpan loc $ do
+ setSrcSpanA loc $ do
(ds', tvs) <- tc_deriv_strategy ds
pure (Just (L loc ds'), tvs)
where
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index ab767b877c..1b2ebf797a 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -205,8 +205,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))) ~ SrcSpan
- , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan
+ , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns
+ , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
, Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
, Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
)
@@ -289,7 +289,7 @@ tcGRHSs :: AnnoBody body
tcGRHSs ctxt (GRHSs _ grhss binds) res_ty
= do { (binds', ugrhss)
<- tcLocalBinds binds $
- mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss
+ mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt res_ty)) grhss
; let (usages, grhss') = unzip ugrhss
; tcEmitBindingUsage $ supUEs usages
; return (GRHSs emptyComments grhss' binds') }
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 3d740948ca..a09d77b6f7 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -1258,7 +1258,7 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of
(L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun))
thing_inside
= do { sel' <- tcLookupId sel
- ; pat_ty <- setSrcSpan loc $ find_field_ty sel
+ ; pat_ty <- setSrcSpanA loc $ find_field_ty sel
(occNameFS $ rdrNameOcc rdr)
; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside
; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat'
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
index a712ab4020..0fabfa626c 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ b/compiler/GHC/Tc/Gen/Rule.hs
@@ -175,7 +175,7 @@ tcRule (HsRule { rd_ext = ext
, rd_name = rname
, rd_act = act
, rd_tyvs = ty_bndrs -- preserved for ppr-ing
- , rd_tmvs = map (noLoc . RuleBndr noAnn . noLocA)
+ , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA)
(qtkvs ++ tpl_ids)
, rd_lhs = mkHsDictLet lhs_binds lhs'
, rd_rhs = mkHsDictLet rhs_binds rhs' } }