summaryrefslogtreecommitdiff
path: root/compiler/rename/RnExpr.hs
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2018-04-01 21:33:53 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2018-04-09 21:29:05 +0200
commit1aa1d405d8212a99ac24dcfd48024a17c3ffd296 (patch)
treedfb9cc90fce7e4a42fd4ca9024477b3d58b60ac5 /compiler/rename/RnExpr.hs
parent48f55e764bb41848cff759fbea3211d8a0bbfd5b (diff)
downloadhaskell-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.hs321
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