diff options
Diffstat (limited to 'compiler/GHC/Rename/Expr.hs')
| -rw-r--r-- | compiler/GHC/Rename/Expr.hs | 379 |
1 files changed, 204 insertions, 175 deletions
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 1ffbc4371a..bbf52be2f8 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -20,7 +21,8 @@ free variables. -} module GHC.Rename.Expr ( - rnLExpr, rnExpr, rnStmts + rnLExpr, rnExpr, rnStmts, + AnnoBody ) where #include "HsVersions.h" @@ -183,18 +185,18 @@ rnExprs ls = rnExprs' ls emptyUniqSet -- Variables. We look up the variable and return the resulting name. rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) -rnLExpr = wrapLocFstM rnExpr +rnLExpr = wrapLocFstMA rnExpr rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars) +finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars) -- Separated from rnExpr because it's also used -- when renaming infix expressions finishHsVar (L l name) = do { this_mod <- getModule ; when (nameIsLocalOrFrom this_mod name) $ checkThLocalName name - ; return (HsVar noExtField (L l name), unitFV name) } + ; return (HsVar noExtField (L (la2na l) name), unitFV name) } rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar v = @@ -204,9 +206,9 @@ rnUnboundVar v = -- and let the type checker report the error return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs) - else -- Fail immediately (qualified name) - do { n <- reportUnboundName v - ; return (HsVar noExtField (noLoc n), emptyFVs) } + else -- Fail immediately (qualified name) + do { n <- reportUnboundName v + ; return (HsVar noExtField (noLocA n), emptyFVs) } rnExpr (HsVar _ (L l v)) = do { dflags <- getDynFlags @@ -220,10 +222,10 @@ rnExpr (HsVar _ (L l v)) -- OverloadedLists works correctly -- Note [Empty lists] in GHC.Hs.Expr , xopt LangExt.OverloadedLists dflags - -> rnExpr (ExplicitList noExtField []) + -> rnExpr (ExplicitList noAnn []) | otherwise - -> finishHsVar (L l name) ; + -> finishHsVar (L (na2la l) name) ; Just (UnambiguousGre (FieldGreName fl)) -> let sel_name = flSelector fl in return ( HsRecFld noExtField (Unambiguous sel_name (L l v) ), unitFV sel_name) ; @@ -234,13 +236,13 @@ rnExpr (HsVar _ (L l v)) rnExpr (HsIPVar x v) = return (HsIPVar x v, emptyFVs) -rnExpr (HsUnboundVar x v) - = return (HsUnboundVar x v, emptyFVs) +rnExpr (HsUnboundVar _ v) + = return (HsUnboundVar noExtField v, emptyFVs) -- HsOverLabel: see Note [Handling overloaded and rebindable constructs] rnExpr (HsOverLabel _ v) = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName - ; return ( mkExpandedExpr (HsOverLabel noExtField v) $ + ; return ( mkExpandedExpr (HsOverLabel noAnn v) $ HsAppType noExtField (genLHsVar from_label) hs_ty_arg , fvs ) } where @@ -263,20 +265,21 @@ rnExpr (HsOverLit x lit) = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] ; case mb_neg of Nothing -> return (HsOverLit x lit', fvs) - Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit')) - , fvs ) } + Just neg -> + return (HsApp noComments (noLocA neg) (noLocA (HsOverLit x lit')) + , fvs ) } rnExpr (HsApp x fun arg) = do { (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnLExpr arg ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType x fun arg) +rnExpr (HsAppType _ fun arg) = do { type_app <- xoptM LangExt.TypeApplications ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg ; (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) } + ; return (HsAppType NoExtField fun' arg', fvFun `plusFV` fvArg) } rnExpr (OpApp _ e1 op e2) = do { (e1', fv_e1) <- rnLExpr e1 @@ -309,17 +312,19 @@ rnExpr (NegApp _ e _) rnExpr (HsGetField _ e f) = do { (getField, fv_getField) <- lookupSyntaxName getFieldName ; (e, fv_e) <- rnLExpr e + ; let f' = rnHsFieldLabel f ; return ( mkExpandedExpr - (HsGetField noExtField e f) - (mkGetField getField e f) + (HsGetField noExtField e f') + (mkGetField getField e (fmap (unLoc . hflLabel) f')) , fv_e `plusFV` fv_getField ) } rnExpr (HsProjection _ fs) = do { (getField, fv_getField) <- lookupSyntaxName getFieldName ; circ <- lookupOccRn compose_RDR + ; let fs' = fmap rnHsFieldLabel fs ; return ( mkExpandedExpr - (HsProjection noExtField fs) - (mkProjection getField circ fs) + (HsProjection noExtField fs') + (mkProjection getField circ (map (fmap (unLoc . hflLabel)) fs')) , unitFV circ `plusFV` fv_getField) } ------------------------------------------ @@ -364,51 +369,50 @@ rnExpr (HsLamCase x matches) = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches ; return (HsLamCase x matches', fvs_ms) } -rnExpr (HsCase x expr matches) +rnExpr (HsCase _ expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet x (L l binds) expr) +rnExpr (HsLet _ binds expr) = rnLocalBindsAndThen binds $ \binds' _ -> do { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet x (L l binds') expr', fvExpr) } + ; return (HsLet noExtField binds' expr', fvExpr) } -rnExpr (HsDo x do_or_lc (L l stmts)) +rnExpr (HsDo _ do_or_lc (L l stmts)) = do { ((stmts', _), fvs) <- - rnStmtsWithPostProcessing do_or_lc rnLExpr + rnStmtsWithPostProcessing do_or_lc rnExpr postProcessStmtsForApplicativeDo stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsDo x do_or_lc (L l stmts'), fvs ) } + ; return ( HsDo noExtField do_or_lc (L l stmts'), fvs ) } -- ExplicitList: see Note [Handling overloaded and rebindable constructs] -rnExpr (ExplicitList x exps) +rnExpr (ExplicitList _ exps) = do { (exps', fvs) <- rnExprs exps ; opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; if not opt_OverloadedLists - then return (ExplicitList x exps', fvs) + then return (ExplicitList noExtField exps', fvs) else do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; let rn_list = ExplicitList x exps' + ; let rn_list = ExplicitList noExtField exps' lit_n = mkIntegralLit (length exps) - hs_lit = wrapGenSpan (HsLit noExtField (HsInt noExtField lit_n)) + hs_lit = wrapGenSpan (HsLit noAnn (HsInt noExtField lit_n)) exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list] ; return ( mkExpandedExpr rn_list exp_list , fvs `plusFV` fvs') } } -rnExpr (ExplicitTuple x tup_args boxity) +rnExpr (ExplicitTuple _ tup_args boxity) = do { checkTupleSection tup_args ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args - ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } + ; return (ExplicitTuple noExtField tup_args' boxity, plusFVs fvs) } where - rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e - ; return (L l (Present x e'), fvs) } - rnTupArg (L l (Missing _)) = return (L l (Missing noExtField) - , emptyFVs) + rnTupArg (Present x e) = do { (e',fvs) <- rnLExpr e + ; return (Present x e', fvs) } + rnTupArg (Missing _) = return (Missing noExtField, emptyFVs) -rnExpr (ExplicitSum x alt arity expr) +rnExpr (ExplicitSum _ alt arity expr) = do { (expr', fvs) <- rnLExpr expr - ; return (ExplicitSum x alt arity expr', fvs) } + ; return (ExplicitSum noExtField alt arity expr', fvs) } rnExpr (RecordCon { rcon_con = con_id , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) @@ -420,7 +424,7 @@ rnExpr (RecordCon { rcon_con = con_id , rcon_con = con_lname, rcon_flds = rec_binds' } , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where - mk_hs_var l n = HsVar noExtField (L l n) + mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n) rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } @@ -476,20 +480,20 @@ rnExpr (HsIf _ p b1 b2) fvs = plusFVs [fvs_if, unitFV ite_name] ; return (mkExpandedExpr rn_if ds_if, fvs) } } -rnExpr (HsMultiIf x alts) +rnExpr (HsMultiIf _ alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts - ; return (HsMultiIf x alts', fvs) } + ; return (HsMultiIf noExtField alts', fvs) } -rnExpr (ArithSeq x _ seq) +rnExpr (ArithSeq _ _ seq) = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; (new_seq, fvs) <- rnArithSeq seq ; if opt_OverloadedLists then do { ; (from_list_name, fvs') <- lookupSyntax fromListName - ; return (ArithSeq x (Just from_list_name) new_seq + ; return (ArithSeq noExtField (Just from_list_name) new_seq , fvs `plusFV` fvs') } else - return (ArithSeq x Nothing new_seq, fvs) } + return (ArithSeq noExtField Nothing new_seq, fvs) } {- ************************************************************************ @@ -541,7 +545,6 @@ rnExpr (HsProc x pat body) rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap - {- ********************************************************************* * * Operator sections @@ -572,9 +575,9 @@ rnSection section@(SectionL x expr op) -- Note [Left and right sections] ; let rn_section = SectionL x expr' op' ds_section - | postfix_ops = HsApp noExtField op' expr' + | postfix_ops = HsApp noAnn op' expr' | otherwise = genHsApps leftSectionName - [wrapGenSpan $ HsApp noExtField op' expr'] + [wrapGenSpan $ HsApp noAnn op' expr'] ; return ( mkExpandedExpr rn_section ds_section , fvs_op `plusFV` fvs_expr) } @@ -694,6 +697,19 @@ bindNonRec will automatically do the right thing, giving us: See #18151. -} +{- +************************************************************************ +* * + Field Labels +* * +************************************************************************ +-} + +rnHsFieldLabel :: Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn) +rnHsFieldLabel (L l (HsFieldLabel x label)) = L l (HsFieldLabel x label) + +rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn +rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnHsFieldLabel fls) {- ************************************************************************ @@ -725,14 +741,14 @@ rnCmdTop = wrapLocFstM rnCmdTop' fvCmd `plusFV` cmd_fvs) } rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) -rnLCmd = wrapLocFstM rnCmd +rnLCmd = wrapLocFstMA rnCmd rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) -rnCmd (HsCmdArrApp x arrow arg ho rtl) +rnCmd (HsCmdArrApp _ arrow arg ho rtl) = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdArrApp x arrow' arg' ho rtl, + ; return (HsCmdArrApp noExtField arrow' arg' ho rtl, fvArrow `plusFV` fvArg) } where select_arrow_scope tc = case ho of @@ -755,34 +771,36 @@ rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2]) ; final_e <- mkOpFormRn arg1' op' fixity arg2' ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } -rnCmd (HsCmdArrForm x op f fixity cmds) +rnCmd (HsCmdArrForm _ op f fixity cmds) = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) ; (cmds',fvCmds) <- rnCmdArgs cmds - ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) } + ; return ( HsCmdArrForm noExtField op' f fixity cmds' + , fvOp `plusFV` fvCmds) } rnCmd (HsCmdApp x fun arg) = do { (fun',fvFun) <- rnLCmd fun ; (arg',fvArg) <- rnLExpr arg ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } -rnCmd (HsCmdLam x matches) +rnCmd (HsCmdLam _ matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches - ; return (HsCmdLam x matches', fvMatch) } + ; return (HsCmdLam noExtField matches', fvMatch) } rnCmd (HsCmdPar x e) = do { (e', fvs_e) <- rnLCmd e ; return (HsCmdPar x e', fvs_e) } -rnCmd (HsCmdCase x expr matches) +rnCmd (HsCmdCase _ expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches - ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCmdCase noExtField new_expr new_matches + , e_fvs `plusFV` ms_fvs) } rnCmd (HsCmdLamCase x matches) = do { (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches ; return (HsCmdLamCase x new_matches, ms_fvs) } -rnCmd (HsCmdIf x _ p b1 b2) +rnCmd (HsCmdIf _ _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLCmd b1 ; (b2', fvB2) <- rnLCmd b2 @@ -792,17 +810,17 @@ rnCmd (HsCmdIf x _ p b1 b2) Just ite_name -> (mkRnSyntaxExpr ite_name, unitFV ite_name) Nothing -> (NoSyntaxExprRn, emptyFVs) - ; return (HsCmdIf x ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} + ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet x (L l binds) cmd) +rnCmd (HsCmdLet _ binds cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet x (L l binds') cmd', fvExpr) } + ; return (HsCmdLet noExtField binds' cmd', fvExpr) } -rnCmd (HsCmdDo x (L l stmts)) +rnCmd (HsCmdDo _ (L l stmts)) = do { ((stmts', _), fvs) <- - rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsCmdDo x (L l stmts'), fvs ) } + rnStmts ArrowExpr rnCmd stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsCmdDo noExtField (L l stmts'), fvs ) } --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are @@ -858,18 +876,18 @@ methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs --------------------------------------------------- -methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars +methodNamesStmts :: [LStmtLR GhcRn GhcRn (LHsCmd GhcRn)] -> FreeVars methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) --------------------------------------------------- -methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars +methodNamesLStmt :: LStmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ _ cmd) = methodNamesLCmd cmd -methodNamesStmt (RecStmt { recS_stmts = stmts }) = +methodNamesStmt (RecStmt { recS_stmts = L _ stmts }) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt {}) = emptyFVs methodNamesStmt (ParStmt {}) = emptyFVs @@ -937,35 +955,42 @@ To get a stable order we use nameSetElemsStable. See Note [Deterministic UniqFM] to learn more about nondeterminism. -} +type AnnoBody body + = ( Outputable (body GhcPs) + , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA + , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA + , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + ) + -- | Rename some Stmts -rnStmts :: Outputable (body GhcPs) +rnStmts :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) - -> [LStmt GhcPs (Located (body GhcPs))] + -> [LStmt GhcPs (LocatedA (body GhcPs))] -- ^ Statements -> ([Name] -> RnM (thing, FreeVars)) -- ^ if these statements scope over something, this renames it -- and returns the result. - -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) + -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars) rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts rnStmtsWithPostProcessing - :: Outputable (body GhcPs) + :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) -> (HsStmtContext GhcRn - -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] - -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)) + -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)) -- ^ postprocess the statements - -> [LStmt GhcPs (Located (body GhcPs))] + -> [LStmt GhcPs (LocatedA (body GhcPs))] -- ^ Statements -> ([Name] -> RnM (thing, FreeVars)) -- ^ if these statements scope over something, this renames it -- and returns the result. - -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) + -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars) rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside @@ -997,17 +1022,17 @@ postProcessStmtsForApplicativeDo ctxt stmts -- | strip the FreeVars annotations from statements noPostProcessStmts :: HsStmtContext GhcRn - -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] - -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars) + -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) -rnStmtsWithFreeVars :: Outputable (body GhcPs) +rnStmtsWithFreeVars :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> [LStmt GhcPs (Located (body GhcPs))] + -> ((body GhcPs) -> RnM ((body GhcRn), FreeVars)) + -> [LStmt GhcPs (LocatedA (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) + -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing) , FreeVars) -- Each Stmt body is annotated with its FreeVars, so that -- we can rearrange statements for ApplicativeDo. @@ -1023,7 +1048,7 @@ rnStmtsWithFreeVars ctxt _ [] thing_inside rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside -- Deal with mdo = -- Behave like do { rec { ...all but last... }; last } do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt mDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> + <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ -> do { last_stmt' <- checkLastStmt mDoExpr last_stmt ; rnStmt mDoExpr rnBody last_stmt' thing_inside } ; return (((stmts1 ++ stmts2), thing), fvs) } @@ -1032,13 +1057,13 @@ rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside -- Deal with rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside | null lstmts - = setSrcSpan loc $ + = setSrcSpanA loc $ do { lstmt' <- checkLastStmt ctxt lstmt ; rnStmt ctxt rnBody lstmt' thing_inside } | otherwise = do { ((stmts1, (stmts2, thing)), fvs) - <- setSrcSpan loc $ + <- setSrcSpanA loc $ do { checkStmt ctxt lstmt ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 -> @@ -1067,20 +1092,20 @@ exhaustive list). How we deal with pattern match failure is context-dependent. At one point we failed to make this distinction, leading to #11216. -} -rnStmt :: Outputable (body GhcPs) +rnStmt :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -- ^ How to rename the body of the statement - -> LStmt GhcPs (Located (body GhcPs)) + -> LStmt GhcPs (LocatedA (body GhcPs)) -- ^ The statement -> ([Name] -> RnM (thing, FreeVars)) -- ^ Rename the stuff that this statement scopes over - -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) + -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing) , FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside +rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- if isMonadCompContext ctxt then lookupStmtName ctxt returnMName @@ -1091,10 +1116,10 @@ rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside -- #15607 ; (thing, fvs3) <- thing_inside [] - ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)] + ; return (([(L loc (LastStmt noExtField (L lb body') noret ret_op), fv_expr)] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } -rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside +rnStmt ctxt rnBody (L loc (BodyStmt _ (L lb body) _ _)) thing_inside = do { (body', fv_expr) <- rnBody body ; (then_op, fvs1) <- lookupQualifiedDoStmtName ctxt thenMName @@ -1106,10 +1131,10 @@ rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside -- Here "gd" is a guard ; (thing, fvs3) <- thing_inside [] - ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)] + ; return ( ([(L loc (BodyStmt noExtField (L lb body') then_op guard_op), fv_expr)] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } -rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside +rnStmt ctxt rnBody (L loc (BindStmt _ pat (L lb body))) thing_inside = do { (body', fv_expr) <- rnBody body -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName @@ -1119,19 +1144,19 @@ rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders CollNoDictBinders pat') ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } - ; return (( [( L loc (BindStmt xbsrn pat' body'), fv_expr )] + ; return (( [( L loc (BindStmt xbsrn pat' (L lb body')), fv_expr )] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside +rnStmt _ _ (L loc (LetStmt _ binds)) thing_inside = rnLocalBindsAndThen binds $ \binds' bind_fvs -> do { (thing, fvs) <- thing_inside (collectLocalBinders CollNoDictBinders binds') - ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing) + ; return ( ([(L loc (LetStmt noAnn binds'), bind_fvs)], thing) , fvs) } -rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside +rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = L _ rec_stmts })) thing_inside = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName ; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName ; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName @@ -1155,7 +1180,7 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside segs -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] ; (thing, fvs_later) <- thing_inside bndrs - ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later + ; let (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs fvs_later -- We aren't going to try to group RecStmts with -- ApplicativeDo, so attaching empty FVs is fine. ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing) @@ -1177,7 +1202,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> + <- rnStmts (TransStmtCtxt ctxt) rnExpr stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs ; let fvs = fvs_by `plusFV` fvs_thing @@ -1229,7 +1254,7 @@ rnParallelStmts ctxt return_op segs thing_inside rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) - <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> + <- rnStmts ctxt rnExpr stmts $ \ bndrs -> setLocalRdrEnv env $ do { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs ; let used_bndrs = filter (`elemNameSet` fvs) bndrs @@ -1264,12 +1289,12 @@ lookupStmtNamePoly ctxt name = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on then do { fm <- lookupOccRn (nameRdrName name) - ; return (HsVar noExtField (noLoc fm), unitFV fm) } + ; return (HsVar noExtField (noLocA fm), unitFV fm) } else not_rebindable } | otherwise = not_rebindable where - not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs) + not_rebindable = return (HsVar noExtField (noLocA name), emptyFVs) -- | Is this a context where we respect RebindableSyntax? -- but ListComp are never rebindable @@ -1325,14 +1350,13 @@ type Segment stmts = (Defs, -- wrapper that does both the left- and right-hand sides -rnRecStmtsAndThen :: Outputable (body GhcPs) => +rnRecStmtsAndThen :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) - -> RnM (Located (body GhcRn), FreeVars)) - -> [LStmt GhcPs (Located (body GhcPs))] + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) + -> [LStmt GhcPs (LocatedA (body GhcPs))] -- assumes that the FreeVars returned includes -- the FreeVars of the Segments - -> ([Segment (LStmt GhcRn (Located (body GhcRn)))] + -> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnRecStmtsAndThen ctxt rnBody s cont @@ -1362,7 +1386,7 @@ rnRecStmtsAndThen ctxt rnBody s cont collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of - (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) -> + (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) -> foldr (\ sig -> \ acc -> case sig of (L loc (FixSig _ s)) -> (L loc s) : acc _ -> acc) acc sigs @@ -1370,12 +1394,12 @@ collectRecStmtsFixities l = -- left-hand sides -rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv - -> LStmt GhcPs body +rn_rec_stmt_lhs :: AnnoBody body => MiniFixityEnv + -> LStmt GhcPs (LocatedA (body GhcPs)) -- rename LHS, and return its FVs -- Warning: we will only need the FreeVars below in the case of a BindStmt, -- so we don't bother to compute it accurately in the other cases - -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] + -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b)) = return [(L loc (BodyStmt noExtField body a b), emptyFVs)] @@ -1387,20 +1411,20 @@ rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body)) = do -- should the ctxt be MDo instead? (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat - return [(L loc (BindStmt noExtField pat' body), fv_pat)] + return [(L loc (BindStmt noAnn pat' body), fv_pat)] -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {})))) +rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {}))) = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds)))) +rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds))) = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds - return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))), + return [(L loc (LetStmt noAnn (HsValBinds x binds')), -- Warning: this is bogus; see function invariant emptyFVs )] -- XXX Do we need to do something with the return and mfix names? -rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec +rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = L _ stmts })) -- Flatten Rec inside Rec = rn_rec_stmts_lhs fix_env stmts rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo @@ -1412,12 +1436,12 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet = pprPanic "rn_rec_stmt" (ppr stmt) -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _)))) +rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" -rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv - -> [LStmt GhcPs body] - -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] +rn_rec_stmts_lhs :: AnnoBody body => MiniFixityEnv + -> [LStmt GhcPs (LocatedA (body GhcPs))] + -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] rn_rec_stmts_lhs fix_env stmts = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts ; let boundNames = collectLStmtsBinders CollNoDictBinders (map fst ls) @@ -1430,28 +1454,28 @@ rn_rec_stmts_lhs fix_env stmts -- right-hand-sides -rn_rec_stmt :: (Outputable (body GhcPs)) => +rn_rec_stmt :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [Name] - -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) - -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] + -> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars) + -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt -rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ body noret _), _) +rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ (L lb body) noret _), _) = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- lookupQualifiedDo ctxt returnMName ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, - L loc (LastStmt noExtField body' noret ret_op))] } + L loc (LastStmt noExtField (L lb body') noret ret_op))] } -rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ body _ _), _) +rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ (L lb body) _ _), _) = do { (body', fvs) <- rnBody body ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] } + L loc (BodyStmt noExtField (L lb body') then_op noSyntaxExpr))] } -rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' body), fv_pat) +rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' (L lb body)), fv_pat) = do { (body', fv_expr) <- rnBody body ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName @@ -1461,17 +1485,17 @@ rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' body), fv_pat) fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt xbsrn pat' body'))] } + L loc (BindStmt xbsrn pat' (L lb body')))] } -rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _) +rn_rec_stmt _ _ _ (L _ (LetStmt _ binds@(HsIPBinds {})), _) = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _) +rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (HsValBinds x binds')), _) = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' -- fixities and unused are handled above in rnRecStmtsAndThen ; let fvs = allUses du_binds ; return [(duDefs du_binds, fvs, emptyNameSet, - L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] } + L loc (LetStmt noAnn (HsValBinds x binds')))] } -- no RecStmt case because they get flattened above when doing the LHSes rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _) @@ -1483,27 +1507,28 @@ rn_rec_stmt _ _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in m rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) +rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _) = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmts :: Outputable (body GhcPs) => +rn_rec_stmts :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [Name] - -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)] - -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] + -> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] + -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] rn_rec_stmts ctxt rnBody bndrs stmts = do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts ; return (concat segs_s) } --------------------------------------------- -segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn - -> Stmt GhcRn body - -> [Segment (LStmt GhcRn body)] -> FreeVars - -> ([LStmt GhcRn body], FreeVars) +segmentRecStmts :: AnnoBody body + => SrcSpan -> HsStmtContext GhcRn + -> Stmt GhcRn (LocatedA (body GhcRn)) + -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> FreeVars + -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later | null segs @@ -1518,8 +1543,8 @@ segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later -- used 'after' the RecStmt | otherwise - = ([ L loc $ - empty_rec_stmt { recS_stmts = ss + = ([ L (noAnnSrcSpan loc) $ + empty_rec_stmt { recS_stmts = noLocA ss , recS_later_ids = nameSetElemsStable (defs `intersectNameSet` fvs_later) , recS_rec_ids = nameSetElemsStable @@ -1636,12 +1661,12 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs) not_needed (defs,_,_,_) = disjointNameSet defs uses ---------------------------------------------------- -segsToStmts :: Stmt GhcRn body +segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn)) -- A RecStmt with the SyntaxOps filled in - -> [Segment [LStmt GhcRn body]] + -> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]] -- Each Segment has a non-empty list of Stmts -> FreeVars -- Free vars used 'later' - -> ([LStmt GhcRn body], FreeVars) + -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later @@ -1651,7 +1676,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later new_stmt | non_rec = head ss | otherwise = L (getLoc (head ss)) rec_stmt - rec_stmt = empty_rec_stmt { recS_stmts = ss + rec_stmt = empty_rec_stmt { recS_stmts = noLocA ss , recS_later_ids = nameSetElemsStable used_later , recS_rec_ids = nameSetElemsStable fwds } -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] @@ -2019,14 +2044,14 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do pvars = nameSetElemsStable pvarset -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] pat = mkBigLHsVarPatTup pvars - tup = mkBigLHsVarTup pvars + tup = mkBigLHsVarTup pvars noExtField (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset (mb_ret, fvs1) <- if | L _ ApplicativeStmt{} <- last stmts' -> return (unLoc tup, emptyNameSet) | otherwise -> do (ret, _) <- lookupQualifiedDoExpr ctxt returnMName - let expr = HsApp noExtField (noLoc ret) tup + let expr = HsApp noComments (noLocA ret) tup return (expr, emptyFVs) return ( ApplicativeArgMany { xarg_app_arg_many = noExtField @@ -2178,10 +2203,10 @@ splitSegment stmts _other -> (stmts,[]) slurpIndependentStmts - :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] - -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts - , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts - , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] ) + :: [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] + -> Maybe ( [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- LetStmts + , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- BindStmts + , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] ) slurpIndependentStmts stmts = go [] [] emptyNameSet stmts where -- If we encounter a BindStmt that doesn't depend on a previous BindStmt @@ -2234,7 +2259,7 @@ mkApplicativeStmt ctxt args need_join body_stmts ; return (Just join_op, fvs) } else return (Nothing, emptyNameSet) - ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField + ; let applicative_stmt = noLocA $ ApplicativeStmt noExtField (zip (fmap_op : repeat ap_op) args) mb_join ; return ( applicative_stmt : body_stmts @@ -2296,9 +2321,9 @@ emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or ' emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt ---------------------- -checkLastStmt :: Outputable (body GhcPs) => HsStmtContext GhcRn - -> LStmt GhcPs (Located (body GhcPs)) - -> RnM (LStmt GhcPs (Located (body GhcPs))) +checkLastStmt :: AnnoBody body => HsStmtContext GhcRn + -> LStmt GhcPs (LocatedA (body GhcPs)) + -> RnM (LStmt GhcPs (LocatedA (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt) = case ctxt of ListComp -> check_comp @@ -2327,7 +2352,7 @@ checkLastStmt ctxt lstmt@(L loc stmt) -- Checking when a particular Stmt is ok checkStmt :: HsStmtContext GhcRn - -> LStmt GhcPs (Located (body GhcPs)) + -> LStmt GhcPs (LocatedA (body GhcPs)) -> RnM () checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags @@ -2354,7 +2379,7 @@ emptyInvalid = NotValid Outputable.empty okStmt, okDoStmt, okCompStmt, okParStmt :: DynFlags -> HsStmtContext GhcRn - -> Stmt GhcPs (Located (body GhcPs)) -> Validity + -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to a generic error message @@ -2371,7 +2396,7 @@ okStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- -okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity +okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity okPatGuardStmt stmt = case stmt of BodyStmt {} -> IsValid @@ -2382,8 +2407,8 @@ okPatGuardStmt stmt ------------- okParStmt dflags ctxt stmt = case stmt of - LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid - _ -> okStmt dflags ctxt stmt + LetStmt _ (HsIPBinds {}) -> emptyInvalid + _ -> okStmt dflags ctxt stmt ---------------- okDoStmt dflags ctxt stmt @@ -2414,7 +2439,7 @@ okCompStmt dflags _ stmt ApplicativeStmt {} -> emptyInvalid --------- -checkTupleSection :: [LHsTupArg GhcPs] -> RnM () +checkTupleSection :: [HsTupArg GhcPs] -> RnM () checkTupleSection args = do { tuple_section <- xoptM LangExt.TupleSections ; checkErr (all tupArgPresent args || tuple_section) msg } @@ -2504,10 +2529,10 @@ getMonadFailOp ctxt arg_name <- newSysName arg_lit let arg_syn_expr = nlHsVar arg_name body :: LHsExpr GhcRn = - nlHsApp (noLoc failExpr) - (nlHsApp (noLoc $ fromStringExpr) arg_syn_expr) + nlHsApp (noLocA failExpr) + (nlHsApp (noLocA $ fromStringExpr) arg_syn_expr) let failAfterFromStringExpr :: HsExpr GhcRn = - unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body + unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocA arg_name] body let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = mkSyntaxExpr failAfterFromStringExpr return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) @@ -2525,7 +2550,7 @@ genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn genHsApps fun args = foldl genHsApp (genHsVar fun) args genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn -genHsApp fun arg = HsApp noExtField (wrapGenSpan fun) arg +genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg genLHsVar :: Name -> LHsExpr GhcRn genLHsVar nm = wrapGenSpan $ genHsVar nm @@ -2539,10 +2564,10 @@ genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs genHsTyLit :: FastString -> HsType GhcRn genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText -wrapGenSpan :: a -> Located a +wrapGenSpan :: a -> LocatedAn an a -- Wrap something in a "generatedSrcSpan" -- See Note [Rebindable syntax and HsExpansion] -wrapGenSpan x = L generatedSrcSpan x +wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x -- | Build a 'HsExpansion' out of an extension constructor, -- and the two components of the expansion: original and @@ -2594,8 +2619,9 @@ mkProjection _ _ [] = panic "mkProjection: The impossible happened" -- e.g. Suppose an update like foo.bar = 1. -- We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1). mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn) -mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds)), hsRecFieldArg = arg } )) +mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds')), hsRecFieldArg = arg } )) = let { + ; flds = map (fmap (unLoc . hflLabel)) flds' ; final = last flds -- quux ; fields = init flds -- [foo, bar, baz] ; getters = \a -> foldl' (mkGet get_field) [a] fields -- Ordered from deep to shallow. @@ -2618,6 +2644,9 @@ rnHsUpdProjs us = do pure (u, plusFVs fvs) where rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars) - rnRecUpdProj (L l (HsRecField fs arg pun)) + rnRecUpdProj (L l (HsRecField _ fs arg pun)) = do { (arg, fv) <- rnLExpr arg - ; return $ (L l (HsRecField { hsRecFieldLbl = fs, hsRecFieldArg = arg, hsRecPun = pun}), fv) } + ; return $ (L l (HsRecField { hsRecFieldAnn = noAnn + , hsRecFieldLbl = fmap rnFieldLabelStrings fs + , hsRecFieldArg = arg + , hsRecPun = pun}), fv) } |