diff options
Diffstat (limited to 'compiler/GHC/Tc/Gen')
-rw-r--r-- | compiler/GHC/Tc/Gen/Arrow.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Expr.hs | 14 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/HsType.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Match.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Pat.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Rule.hs | 2 |
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' } } |