return (HsLet binds' expr', fvExpr)
rnExpr (HsDo do_or_lc stmts body _)
- = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
+ = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ ->
rnLExpr body
; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
where
doc = text "In an expression type signature"
-rnExpr (HsIf p b1 b2)
- = rnLExpr p `thenM` \ (p', fvP) ->
- rnLExpr b1 `thenM` \ (b1', fvB1) ->
- rnLExpr b2 `thenM` \ (b2', fvB2) ->
- return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
+rnExpr (HsIf _ p b1 b2)
+ = do { (p', fvP) <- rnLExpr p
+ ; (b1', fvB1) <- rnLExpr b1
+ ; (b2', fvB2) <- rnLExpr b2
+ ; rebind <- xoptM Opt_RebindableSyntax
+ ; if not rebind
+ then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2])
+ else do { c <- liftM HsVar (lookupOccRn (mkVarUnqual (fsLit "ifThenElse")))
+ ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }}
rnExpr (HsType a)
= rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
convertOpFormsCmd (HsCase exp matches)
= HsCase exp (convertOpFormsMatch matches)
-convertOpFormsCmd (HsIf exp c1 c2)
- = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
+convertOpFormsCmd (HsIf f exp c1 c2)
+ = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
convertOpFormsCmd (HsLet binds cmd)
= HsLet binds (convertOpFormsLCmd cmd)
methodNamesCmd (HsPar c) = methodNamesLCmd c
-methodNamesCmd (HsIf _ c1 c2)
+methodNamesCmd (HsIf _ _ c1 c2)
= methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
methodNamesCmd (HsLet _ c) = methodNamesLCmd c
%************************************************************************
\begin{code}
-rnStmts :: HsStmtContext Name -> [LStmt RdrName]
- -> RnM (thing, FreeVars)
- -> RnM (([LStmt Name], thing), FreeVars)
--- Variables bound by the Stmts, and mentioned in thing_inside,
--- do not appear in the result FreeVars
-
-rnStmts (MDoExpr _) stmts thing_inside = rnMDoStmts stmts thing_inside
-rnStmts ctxt stmts thing_inside = rnNormalStmts ctxt stmts (\ _ -> thing_inside)
-
-rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
+rnStmts :: HsStmtContext Name -> [LStmt RdrName]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt Name], thing), FreeVars)
-- Variables bound by the Stmts, and mentioned in thing_inside,
--
-- Renaming a single RecStmt can give a sequence of smaller Stmts
-rnNormalStmts _ [] thing_inside
+rnStmts _ [] thing_inside
= do { (res, fvs) <- thing_inside []
; return (([], res), fvs) }
-rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside
+rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
= do { ((stmts1, (stmts2, thing)), fvs)
<- setSrcSpan loc $
rnStmt ctxt stmt $ \ bndrs1 ->
- rnNormalStmts ctxt stmts $ \ bndrs2 ->
+ rnStmts ctxt stmts $ \ bndrs2 ->
thing_inside (bndrs1 ++ bndrs2)
; return (((stmts1 ++ stmts2), thing), fvs) }
-- for which it's the fwd refs within the bind itself
-- (This set may not be empty, because we're in a recursive
-- context.)
- ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
+ ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
{ let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
emptyNameSet segs
; (using', fvs1) <- rnLExpr using
; ((stmts', (by', used_bndrs, thing)), fvs2)
- <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
+ <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- case by of
Nothing -> return (Nothing, emptyFVs)
Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
- used_bndrs = filter (`elemNameSet` fvs_thing) bndrs
+ used_bndrs = filter (`elemNameSet` fvs) bndrs
+ -- The paper (Fig 5) has a bug here; we must treat any free varaible of
+ -- the "thing inside", **or of the by-expression**, as used
; return ((by', used_bndrs, thing), fvs) }
; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
-- Rename the stmts and the 'by' expression
-- Keep track of the variables mentioned in the 'by' expression
; ((stmts', (by', used_bndrs, thing)), fvs2)
- <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
+ <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
rn_segs env bndrs_so_far ((stmts,_) : segs)
= do { ((stmts', (used_bndrs, segs', thing)), fvs)
- <- rnNormalStmts ctxt stmts $ \ bndrs ->
+ <- rnStmts ctxt stmts $ \ bndrs ->
setLocalRdrEnv env $ do
{ ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
; let used_bndrs = filter (`elemNameSet` fvs) bndrs
stmts) -- Either Stmt or [Stmt]
-----------------------------------------------------
-
-rnMDoStmts :: [LStmt RdrName]
- -> RnM (thing, FreeVars)
- -> RnM (([LStmt Name], thing), FreeVars)
-rnMDoStmts stmts thing_inside
- = rn_rec_stmts_and_then stmts $ \ segs -> do
- { (thing, fvs_later) <- thing_inside
- ; let segs_w_fwd_refs = addFwdRefs segs
- grouped_segs = glomSegments segs_w_fwd_refs
- (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later
- ; return ((stmts', thing), fvs) }
-
----------------------------------------------
-
-- wrapper that does both the left- and right-hand sides
-rn_rec_stmts_and_then :: [LStmt RdrName]
+rnRecStmtsAndThen :: [LStmt RdrName]
-- assumes that the FreeVars returned includes
-- the FreeVars of the Segments
-> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-rn_rec_stmts_and_then s cont
+rnRecStmtsAndThen s cont
= do { -- (A) Make the mini fixity env for all of the stmts
fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
(binds', du_binds) <-
- -- fixities and unused are handled above in rn_rec_stmts_and_then
+ -- fixities and unused are handled above in rnRecStmtsAndThen
rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
return [(duDefs du_binds, allUses du_binds,
emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
---------
checkRecStmt :: HsStmtContext Name -> RnM ()
-checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
-checkRecStmt (DoExpr {}) = return () -- and in 'do'
-checkRecStmt ctxt = addErr msg
+checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
+checkRecStmt DoExpr = return () -- and in 'do'
+checkRecStmt ctxt = addErr msg
where
msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt