diff options
author | Alan Zimmerman <alan.zimm@gmail.com> | 2018-04-01 21:33:53 +0200 |
---|---|---|
committer | Alan Zimmerman <alan.zimm@gmail.com> | 2018-04-09 21:29:05 +0200 |
commit | 1aa1d405d8212a99ac24dcfd48024a17c3ffd296 (patch) | |
tree | dfb9cc90fce7e4a42fd4ca9024477b3d58b60ac5 /compiler/rename/RnExpr.hs | |
parent | 48f55e764bb41848cff759fbea3211d8a0bbfd5b (diff) | |
download | haskell-1aa1d405d8212a99ac24dcfd48024a17c3ffd296.tar.gz |
Restore Trees That Grow reverted commits
The following commits were reverted prior to the release of GHC 8.4.1,
because the time to derive Data instances was too long [1].
438dd1cbba13d35f3452b4dcef3f94ce9a216905 Phab:D4147
e3ec2e7ae94524ebd111963faf34b84d942265b4 Phab:D4177
47ad6578ea460999b53eb4293c3a3b3017a56d65 Phab:D4186
The work is continuing, as the minimum bootstrap compiler is now
GHC 8.2.1, and this allows Plan B[2] for instances to be used. This
will land in a following commit.
Updates Haddock submodule
[1] https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/Instances
[2] https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/Instances#PLANB
Diffstat (limited to 'compiler/rename/RnExpr.hs')
-rw-r--r-- | compiler/rename/RnExpr.hs | 321 |
1 files changed, 162 insertions, 159 deletions
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index ced46a367e..ec2b09f80d 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -95,7 +95,7 @@ finishHsVar (L l name) = do { this_mod <- getModule ; when (nameIsLocalOrFrom this_mod name) $ checkThLocalName name - ; return (HsVar (L l name), unitFV name) } + ; return (HsVar noExt (L l name), unitFV name) } rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar v @@ -107,13 +107,13 @@ rnUnboundVar v ; uv <- if startsWithUnderscore occ then return (TrueExprHole occ) else OutOfScope occ <$> getGlobalRdrEnv - ; return (HsUnboundVar uv, emptyFVs) } + ; return (HsUnboundVar noExt uv, emptyFVs) } else -- Fail immediately (qualified name) do { n <- reportUnboundName v - ; return (HsVar (noLoc n), emptyFVs) } } + ; return (HsVar noExt (noLoc n), emptyFVs) } } -rnExpr (HsVar (L l v)) +rnExpr (HsVar _ (L l v)) = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v ; case mb_name of { @@ -121,58 +121,57 @@ rnExpr (HsVar (L l v)) Just (Left name) | name == nilDataConName -- Treat [] as an ExplicitList, so that -- OverloadedLists works correctly - -> rnExpr (ExplicitList placeHolderType Nothing []) + -> rnExpr (ExplicitList noExt Nothing []) | otherwise -> finishHsVar (L l name) ; Just (Right [s]) -> - return ( HsRecFld (ambiguousFieldOcc (FieldOcc (L l v) s)) - , unitFV s) ; + return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ; Just (Right fs@(_:_:_)) -> - return ( HsRecFld (Ambiguous (L l v) PlaceHolder) + return ( HsRecFld noExt (Ambiguous noExt (L l v)) , mkFVs fs); Just (Right []) -> panic "runExpr/HsVar" } } -rnExpr (HsIPVar v) - = return (HsIPVar v, emptyFVs) +rnExpr (HsIPVar x v) + = return (HsIPVar x v, emptyFVs) -rnExpr (HsOverLabel _ v) +rnExpr (HsOverLabel x _ v) = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel")) - ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) } - else return (HsOverLabel Nothing v, emptyFVs) } + ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) } + else return (HsOverLabel x Nothing v, emptyFVs) } -rnExpr (HsLit lit@(HsString src s)) +rnExpr (HsLit x lit@(HsString src s)) = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings ; if opt_OverloadedStrings then - rnExpr (HsOverLit (mkHsIsString src s placeHolderType)) + rnExpr (HsOverLit x (mkHsIsString src s)) else do { ; rnLit lit - ; return (HsLit (convertLit lit), emptyFVs) } } + ; return (HsLit x (convertLit lit), emptyFVs) } } -rnExpr (HsLit lit) +rnExpr (HsLit x lit) = do { rnLit lit - ; return (HsLit (convertLit lit), emptyFVs) } + ; return (HsLit x(convertLit lit), emptyFVs) } -rnExpr (HsOverLit lit) +rnExpr (HsOverLit x lit) = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] ; case mb_neg of - Nothing -> return (HsOverLit lit', fvs) - Just neg -> return ( HsApp (noLoc neg) (noLoc (HsOverLit lit')) + Nothing -> return (HsOverLit x lit', fvs) + Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit')) , fvs ) } -rnExpr (HsApp fun arg) +rnExpr (HsApp x fun arg) = do { (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnLExpr arg - ; return (HsApp fun' arg', fvFun `plusFV` fvArg) } + ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType fun arg) +rnExpr (HsAppType arg fun) = do { (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) } + ; return (HsAppType arg' fun', fvFun `plusFV` fvArg) } -rnExpr (OpApp e1 op _ e2) +rnExpr (OpApp _ e1 op e2) = do { (e1', fv_e1) <- rnLExpr e1 ; (e2', fv_e2) <- rnLExpr e2 ; (op', fv_op) <- rnLExpr op @@ -183,15 +182,15 @@ rnExpr (OpApp e1 op _ e2) -- more, so I've removed the test. Adding HsPars in TcGenDeriv -- should prevent bad things happening. ; fixity <- case op' of - L _ (HsVar (L _ n)) -> lookupFixityRn n - L _ (HsRecFld f) -> lookupFieldFixityRn f + L _ (HsVar _ (L _ n)) -> lookupFixityRn n + L _ (HsRecFld _ f) -> lookupFieldFixityRn f _ -> return (Fixity NoSourceText minPrecedence InfixL) -- c.f. lookupFixity for unbound ; final_e <- mkOpAppRn e1' op' fixity e2' ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } -rnExpr (NegApp e _) +rnExpr (NegApp _ e _) = do { (e', fv_e) <- rnLExpr e ; (neg_name, fv_neg) <- lookupSyntaxName negateName ; final_e <- mkNegAppRn e' neg_name @@ -201,24 +200,24 @@ rnExpr (NegApp e _) -- Template Haskell extensions -- Don't ifdef-GHCI them because we want to fail gracefully -- (not with an rnExpr crash) in a stage-1 compiler. -rnExpr e@(HsBracket br_body) = rnBracket e br_body +rnExpr e@(HsBracket _ br_body) = rnBracket e br_body -rnExpr (HsSpliceE splice) = rnSpliceExpr splice +rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice --------------------------------------------- -- Sections -- See Note [Parsing sections] in Parser.y -rnExpr (HsPar (L loc (section@(SectionL {})))) +rnExpr (HsPar x (L loc (section@(SectionL {})))) = do { (section', fvs) <- rnSection section - ; return (HsPar (L loc section'), fvs) } + ; return (HsPar x (L loc section'), fvs) } -rnExpr (HsPar (L loc (section@(SectionR {})))) +rnExpr (HsPar x (L loc (section@(SectionR {})))) = do { (section', fvs) <- rnSection section - ; return (HsPar (L loc section'), fvs) } + ; return (HsPar x (L loc section'), fvs) } -rnExpr (HsPar e) +rnExpr (HsPar x e) = do { (e', fvs_e) <- rnLExpr e - ; return (HsPar e', fvs_e) } + ; return (HsPar x e', fvs_e) } rnExpr expr@(SectionL {}) = do { addErr (sectionErr expr); rnSection expr } @@ -226,71 +225,72 @@ rnExpr expr@(SectionR {}) = do { addErr (sectionErr expr); rnSection expr } --------------------------------------------- -rnExpr (HsCoreAnn src ann expr) +rnExpr (HsCoreAnn x src ann expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsCoreAnn src ann expr', fvs_expr) } + ; return (HsCoreAnn x src ann expr', fvs_expr) } -rnExpr (HsSCC src lbl expr) +rnExpr (HsSCC x src lbl expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsSCC src lbl expr', fvs_expr) } -rnExpr (HsTickPragma src info srcInfo expr) + ; return (HsSCC x src lbl expr', fvs_expr) } +rnExpr (HsTickPragma x src info srcInfo expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsTickPragma src info srcInfo expr', fvs_expr) } + ; return (HsTickPragma x src info srcInfo expr', fvs_expr) } -rnExpr (HsLam matches) +rnExpr (HsLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches - ; return (HsLam matches', fvMatch) } + ; return (HsLam x matches', fvMatch) } -rnExpr (HsLamCase matches) +rnExpr (HsLamCase x matches) = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsLamCase matches', fvs_ms) } + ; return (HsLamCase x matches', fvs_ms) } -rnExpr (HsCase expr matches) +rnExpr (HsCase x expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet (L l binds) expr) +rnExpr (HsLet x (L l binds) expr) = rnLocalBindsAndThen binds $ \binds' _ -> do { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet (L l binds') expr', fvExpr) } + ; return (HsLet x (L l binds') expr', fvExpr) } -rnExpr (HsDo do_or_lc (L l stmts) _) +rnExpr (HsDo x do_or_lc (L l stmts)) = do { ((stmts', _), fvs) <- rnStmtsWithPostProcessing do_or_lc rnLExpr postProcessStmtsForApplicativeDo stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) } + ; return ( HsDo x do_or_lc (L l stmts'), fvs ) } -rnExpr (ExplicitList _ _ exps) +rnExpr (ExplicitList x _ exps) = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; (exps', fvs) <- rnExprs exps ; if opt_OverloadedLists then do { ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; return (ExplicitList placeHolderType (Just from_list_n_name) exps' + ; return (ExplicitList x (Just from_list_n_name) exps' , fvs `plusFV` fvs') } else - return (ExplicitList placeHolderType Nothing exps', fvs) } + return (ExplicitList x Nothing exps', fvs) } -rnExpr (ExplicitPArr _ exps) +rnExpr (ExplicitPArr x exps) = do { (exps', fvs) <- rnExprs exps - ; return (ExplicitPArr placeHolderType exps', fvs) } + ; return (ExplicitPArr x exps', fvs) } -rnExpr (ExplicitTuple tup_args boxity) +rnExpr (ExplicitTuple x tup_args boxity) = do { checkTupleSection tup_args ; checkTupSize (length tup_args) ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args - ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) } + ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } where - rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e - ; return (L l (Present e'), fvs) } - rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType) + 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 noExt) , emptyFVs) + rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg" -rnExpr (ExplicitSum alt arity expr _) +rnExpr (ExplicitSum x alt arity expr) = do { (expr', fvs) <- rnLExpr expr - ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) } + ; return (ExplicitSum x alt arity expr', fvs) } rnExpr (RecordCon { rcon_con_name = con_id , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) @@ -298,53 +298,53 @@ rnExpr (RecordCon { rcon_con_name = con_id ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } - ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds' - , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } + ; return (RecordCon { rcon_ext = noExt + , rcon_con_name = con_lname, rcon_flds = rec_binds' } , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where - mk_hs_var l n = HsVar (L l n) + mk_hs_var l n = HsVar noExt (L l n) rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) = do { (expr', fvExpr) <- rnLExpr expr ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds - ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds' - , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder - , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder } + ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr' + , rupd_flds = rbinds' } , fvExpr `plusFV` fvRbinds) } -rnExpr (ExprWithTySig expr pty) +rnExpr (ExprWithTySig pty expr) = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ rnLExpr expr - ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } + ; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) } -rnExpr (HsIf _ p b1 b2) +rnExpr (HsIf x _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLExpr b1 ; (b2', fvB2) <- rnLExpr b2 ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } -rnExpr (HsMultiIf _ty alts) +rnExpr (HsMultiIf x alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts -- ; return (HsMultiIf ty alts', fvs) } - ; return (HsMultiIf placeHolderType alts', fvs) } + ; return (HsMultiIf x alts', fvs) } -rnExpr (ArithSeq _ _ seq) +rnExpr (ArithSeq x _ seq) = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; (new_seq, fvs) <- rnArithSeq seq ; if opt_OverloadedLists then do { ; (from_list_name, fvs') <- lookupSyntaxName fromListName - ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } + ; return (ArithSeq x (Just from_list_name) new_seq + , fvs `plusFV` fvs') } else - return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } + return (ArithSeq x Nothing new_seq, fvs) } -rnExpr (PArrSeq _ seq) +rnExpr (PArrSeq x seq) = do { (new_seq, fvs) <- rnArithSeq seq - ; return (PArrSeq noPostTcExpr new_seq, fvs) } + ; return (PArrSeq x new_seq, fvs) } {- These three are pattern syntax appearing in expressions. @@ -352,7 +352,7 @@ Since all the symbols are reservedops we can simply reject them. We return a (bogus) EWildPat in each case. -} -rnExpr EWildPat = return (hsHoleExpr, emptyFVs) -- "_" is just a hole +rnExpr (EWildPat _) = return (hsHoleExpr, emptyFVs) -- "_" is just a hole rnExpr e@(EAsPat {}) = do { opt_TypeApplications <- xoptM LangExt.TypeApplications ; let msg | opt_TypeApplications @@ -407,11 +407,11 @@ rnExpr e@(HsStatic _ expr) = do ************************************************************************ -} -rnExpr (HsProc pat body) +rnExpr (HsProc x pat body) = newArrowScope $ rnPat ProcExpr pat $ \ pat' -> do { (body',fvBody) <- rnCmdTop body - ; return (HsProc pat' body', fvBody) } + ; return (HsProc x pat' body', fvBody) } -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. rnExpr e@(HsArrApp {}) = arrowFail e @@ -420,8 +420,8 @@ rnExpr e@(HsArrForm {}) = arrowFail e rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap -hsHoleExpr :: HsExpr id -hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_")) +hsHoleExpr :: HsExpr (GhcPass id) +hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) arrowFail e @@ -434,17 +434,17 @@ arrowFail e ---------------------- -- See Note [Parsing sections] in Parser.y rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -rnSection section@(SectionR op expr) +rnSection section@(SectionR x op expr) = do { (op', fvs_op) <- rnLExpr op ; (expr', fvs_expr) <- rnLExpr expr ; checkSectionPrec InfixR section op' expr' - ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) } + ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) } -rnSection section@(SectionL expr op) +rnSection section@(SectionL x expr op) = do { (expr', fvs_expr) <- rnLExpr expr ; (op', fvs_op) <- rnLExpr op ; checkSectionPrec InfixL section op' expr' - ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) } + ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) } rnSection other = pprPanic "rnSection" (ppr other) @@ -466,26 +466,26 @@ rnCmdArgs (arg:args) rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where - rnCmdTop' (HsCmdTop cmd _ _ _) + rnCmdTop' (HsCmdTop _ cmd) = do { (cmd', fvCmd) <- rnLCmd cmd ; let cmd_names = [arrAName, composeAName, firstAName] ++ nameSetElemsStable (methodNamesCmd (unLoc cmd')) -- Generate the rebindable syntax for the monad ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - ; return (HsCmdTop cmd' placeHolderType placeHolderType - (cmd_names `zip` cmd_names'), + ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', fvCmd `plusFV` cmd_fvs) } + rnCmdTop' (XCmdTop{}) = panic "rnCmdTop" rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) rnLCmd = wrapLocFstM rnCmd rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) -rnCmd (HsCmdArrApp arrow arg _ ho rtl) +rnCmd (HsCmdArrApp x arrow arg ho rtl) = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, + ; return (HsCmdArrApp x arrow' arg' ho rtl, fvArrow `plusFV` fvArg) } where select_arrow_scope tc = case ho of @@ -498,9 +498,9 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl) -- inside 'arrow'. In the higher-order case (-<<), they are. -- infix form -rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2]) +rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2]) = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) - ; let L _ (HsVar (L _ op_name)) = op' + ; let L _ (HsVar _ (L _ op_name)) = op' ; (arg1',fv_arg1) <- rnCmdTop arg1 ; (arg2',fv_arg2) <- rnCmdTop arg2 -- Deal with fixity @@ -508,47 +508,48 @@ 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 op f fixity cmds) +rnCmd (HsCmdArrForm x op f fixity cmds) = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) ; (cmds',fvCmds) <- rnCmdArgs cmds - ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) } + ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) } -rnCmd (HsCmdApp fun arg) +rnCmd (HsCmdApp x fun arg) = do { (fun',fvFun) <- rnLCmd fun ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) } + ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } -rnCmd (HsCmdLam matches) +rnCmd (HsCmdLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches - ; return (HsCmdLam matches', fvMatch) } + ; return (HsCmdLam x matches', fvMatch) } -rnCmd (HsCmdPar e) +rnCmd (HsCmdPar x e) = do { (e', fvs_e) <- rnLCmd e - ; return (HsCmdPar e', fvs_e) } + ; return (HsCmdPar x e', fvs_e) } -rnCmd (HsCmdCase expr matches) +rnCmd (HsCmdCase x expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches - ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnCmd (HsCmdIf _ p b1 b2) +rnCmd (HsCmdIf x _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLCmd b1 ; (b2', fvB2) <- rnLCmd b2 ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet (L l binds) cmd) +rnCmd (HsCmdLet x (L l binds) cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet (L l binds') cmd', fvExpr) } + ; return (HsCmdLet x (L l binds') cmd', fvExpr) } -rnCmd (HsCmdDo (L l stmts) _) +rnCmd (HsCmdDo x (L l stmts)) = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) } + ; return ( HsCmdDo x (L l stmts'), fvs ) } rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd) +rnCmd cmd@(XCmd {}) = pprPanic "rnCmd" (ppr cmd) --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are @@ -560,26 +561,28 @@ methodNamesLCmd = methodNamesCmd . unLoc methodNamesCmd :: HsCmd GhcRn -> CmdNeeds -methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl) = emptyFVs -methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl) +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl) = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd +methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd -methodNamesCmd (HsCmdPar c) = methodNamesLCmd c +methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdIf _ _ c1 c2) +methodNamesCmd (HsCmdIf _ _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts -methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c -methodNamesCmd (HsCmdLam match) = methodNamesMatch match +methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts +methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c +methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match -methodNamesCmd (HsCmdCase _ matches) +methodNamesCmd (HsCmdCase _ _ matches) = methodNamesMatch matches `addOneFV` choiceAName +methodNamesCmd (XCmd {}) = panic "methodNamesCmd" + --methodNamesCmd _ = emptyFVs -- Other forms can't occur in commands, but it's not convenient -- to error here so we just do what's convenient. @@ -863,7 +866,7 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder) + ; return (( [( L loc (BindStmt pat' body' bind_op fail_op placeHolder) , fv_expr )] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} @@ -946,7 +949,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map , trS_by = by', trS_using = using', trS_form = form , trS_ret = return_op, trS_bind = bind_op - , trS_bind_arg_ty = PlaceHolder + , trS_bind_arg_ty = placeHolder , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } rnStmt _ _ (L _ ApplicativeStmt{}) _ = @@ -971,7 +974,7 @@ rnParallelStmts ctxt return_op segs thing_inside ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') ; return (([], thing), fvs) } - rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) + rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> setLocalRdrEnv env $ do @@ -979,8 +982,9 @@ rnParallelStmts ctxt return_op segs thing_inside ; let used_bndrs = filter (`elemNameSet` fvs) bndrs ; return ((used_bndrs, segs', thing), fvs) } - ; let seg' = ParStmtBlock stmts' used_bndrs return_op + ; let seg' = ParStmtBlock x stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) } + rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts" cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" @@ -1000,12 +1004,12 @@ lookupStmtNamePoly ctxt name = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on then do { fm <- lookupOccRn (nameRdrName name) - ; return (HsVar (noLoc fm), unitFV fm) } + ; return (HsVar noExt (noLoc fm), unitFV fm) } else not_rebindable } | otherwise = not_rebindable where - not_rebindable = return (HsVar (noLoc name), emptyFVs) + not_rebindable = return (HsVar noExt (noLoc name), emptyFVs) -- | Is this a context where we respect RebindableSyntax? -- but ListComp/PArrComp are never rebindable @@ -1095,7 +1099,7 @@ rnRecStmtsAndThen rnBody s cont collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of - (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) -> + (L _ (LetStmt (L _ (HsValBinds (ValBinds _ _ sigs))))) -> foldr (\ sig -> \ acc -> case sig of (L loc (FixSig s)) -> (L loc s) : acc _ -> acc) acc sigs @@ -1196,7 +1200,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat) ; let bndrs = mkNameSet (collectPatBinders pat') fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] } + L loc (BindStmt pat' body' bind_op fail_op placeHolder))] } rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _) = failWith (badIpBinds (text "an mdo expression") binds) @@ -1700,7 +1704,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do return (unLoc tup, emptyNameSet) | otherwise -> do (ret,fvs) <- lookupStmtNamePoly ctxt returnMName - return (HsApp (noLoc ret) tup, fvs) + return (HsApp noExt (noLoc ret) tup, fvs) return ( ApplicativeArgMany stmts' mb_ret pat , fvs1 `plusFV` fvs2) @@ -1786,25 +1790,24 @@ can do with the rest of the statements in the same "do" expression. isStrictPattern :: LPat id -> Bool isStrictPattern (L _ pat) = case pat of - WildPat{} -> False - VarPat{} -> False - LazyPat{} -> False - AsPat _ p -> isStrictPattern p - ParPat p -> isStrictPattern p - ViewPat _ p _ -> isStrictPattern p - SigPatIn p _ -> isStrictPattern p - SigPatOut p _ -> isStrictPattern p - BangPat{} -> True - ListPat{} -> True - TuplePat{} -> True - SumPat{} -> True - PArrPat{} -> True - ConPatIn{} -> True - ConPatOut{} -> True - LitPat{} -> True - NPat{} -> True - NPlusKPat{} -> True - SplicePat{} -> True + WildPat{} -> False + VarPat{} -> False + LazyPat{} -> False + AsPat _ _ p -> isStrictPattern p + ParPat _ p -> isStrictPattern p + ViewPat _ _ p -> isStrictPattern p + SigPat _ p -> isStrictPattern p + BangPat{} -> True + ListPat{} -> True + TuplePat{} -> True + SumPat{} -> True + PArrPat{} -> True + ConPatIn{} -> True + ConPatOut{} -> True + LitPat{} -> True + NPat{} -> True + NPlusKPat{} -> True + SplicePat{} -> True _otherwise -> panic "isStrictPattern" isLetStmt :: LStmt a b -> Bool @@ -1912,15 +1915,15 @@ needJoin _monad_names stmts = (True, stmts) isReturnApp :: MonadNames -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn) -isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr +isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr isReturnApp monad_names (L _ e) = case e of - OpApp l op _ r | is_return l, is_dollar op -> Just r - HsApp f arg | is_return f -> Just arg + OpApp _ l op r | is_return l, is_dollar op -> Just r + HsApp _ f arg | is_return f -> Just arg _otherwise -> Nothing where - is_var f (L _ (HsPar e)) = is_var f e - is_var f (L _ (HsAppType e _)) = is_var f e - is_var f (L _ (HsVar (L _ r))) = f r + is_var f (L _ (HsPar _ e)) = is_var f e + is_var f (L _ (HsAppType _ e)) = is_var f e + is_var f (L _ (HsVar _ (L _ r))) = f r -- TODO: I don't know how to get this right for rebindable syntax is_var _ _ = False @@ -2102,7 +2105,7 @@ patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars) patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:", nest 4 (ppr e)] $$ explanation) - ; return (EWildPat, emptyFVs) } + ; return (EWildPat noExt, emptyFVs) } badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds |