+rnStmts :: HsStmtContext Name -> [LStmt RdrName]
+ -> RnM (thing, FreeVars)
+ -> RnM (([LStmt Name], thing), FreeVars)
+
+rnStmts (MDoExpr _) = rnMDoStmts
+rnStmts ctxt = rnNormalStmts ctxt
+
+rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
+ -> RnM (thing, FreeVars)
+ -> RnM (([LStmt Name], thing), FreeVars)
+-- Used for cases *other* than recursive mdo
+-- Implements nested scopes
+
+rnNormalStmts ctxt [] thing_inside
+ = do { (thing, fvs) <- thing_inside
+ ; return (([],thing), fvs) }
+
+rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
+ = do { ((stmt', (stmts', thing)), fvs)
+ <- rnStmt ctxt stmt $
+ rnNormalStmts ctxt stmts thing_inside
+ ; return (((L loc stmt' : stmts'), thing), fvs) }
+
+rnStmt :: HsStmtContext Name -> Stmt RdrName
+ -> RnM (thing, FreeVars)
+ -> RnM ((Stmt Name, thing), FreeVars)
+
+rnStmt ctxt (ExprStmt expr _ _) thing_inside
+ = do { (expr', fv_expr) <- rnLExpr expr
+ ; (then_op, fvs1) <- lookupSyntaxName thenMName
+ ; (thing, fvs2) <- thing_inside
+ ; return ((ExprStmt expr' then_op placeHolderType, thing),
+ fv_expr `plusFV` fvs1 `plusFV` fvs2) }
+
+rnStmt ctxt (BindStmt pat expr _ _) thing_inside
+ = do { (expr', fv_expr) <- rnLExpr expr
+ -- The binders do not scope over the expression
+ ; (bind_op, fvs1) <- lookupSyntaxName bindMName
+ ; (fail_op, fvs2) <- lookupSyntaxName failMName
+ ; rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
+ { (thing, fvs3) <- thing_inside
+ ; return ((BindStmt pat' expr' bind_op fail_op, 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 ctxt (LetStmt binds) thing_inside
+ = do { checkErr (ok ctxt binds)
+ (badIpBinds (ptext SLIT("a parallel list comprehension:")) binds)
+ ; rnLocalBindsAndThen binds $ \ binds' -> do
+ { (thing, fvs) <- thing_inside
+ ; return ((LetStmt binds', thing), fvs) }}
+ where
+ -- We do not allow implicit-parameter bindings in a parallel
+ -- list comprehension. I'm not sure what it might mean.
+ ok (ParStmtCtxt _) (HsIPBinds _) = False
+ ok _ _ = True
+
+rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
+ = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ bndrs ->
+ rn_rec_stmts bndrs rec_stmts `thenM` \ segs ->
+ thing_inside `thenM` \ (thing, fvs) ->
+ let
+ segs_w_fwd_refs = addFwdRefs segs
+ (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
+ later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
+ fwd_vars = nameSetToList (plusFVs fs)
+ uses = plusFVs us
+ rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
+ in
+ returnM ((rec_stmt, thing), uses `plusFV` fvs)
+ where
+ doc = text "In a recursive do statement"
+
+rnStmt ctxt (ParStmt segs) thing_inside
+ = do { opt_GlasgowExts <- doptM Opt_GlasgowExts
+ ; checkM opt_GlasgowExts parStmtErr
+ ; orig_lcl_env <- getLocalRdrEnv
+ ; ((segs',thing), fvs) <- go orig_lcl_env [] segs
+ ; return ((ParStmt segs', thing), fvs) }
+ where
+-- type ParSeg id = [([LStmt id], [id])]
+-- go :: NameSet -> [ParSeg RdrName]
+-- -> RnM (([ParSeg Name], thing), FreeVars)
+
+ go orig_lcl_env bndrs []
+ = do { let { (bndrs', dups) = removeDups cmpByOcc bndrs
+ ; inner_env = extendLocalRdrEnv orig_lcl_env bndrs' }
+ ; mappM dupErr dups
+ ; (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
+ ; return (([], thing), fvs) }
+
+ go orig_lcl_env bndrs_so_far ((stmts, _) : segs)
+ = do { ((stmts', (bndrs, segs', thing)), fvs)
+ <- rnNormalStmts par_ctxt stmts $ do
+ { -- Find the Names that are bound by stmts
+ lcl_env <- getLocalRdrEnv
+ ; let { rdr_bndrs = collectLStmtsBinders stmts
+ ; bndrs = map ( fromJust
+ . lookupLocalRdrEnv lcl_env
+ . unLoc) rdr_bndrs
+ ; new_bndrs = nub bndrs ++ bndrs_so_far
+ -- The nub is because there might be shadowing
+ -- x <- e1; x <- e2
+ -- So we'll look up (Unqual x) twice, getting
+ -- the second binding both times, which is the
+ } -- one we want
+
+ -- Typecheck the thing inside, passing on all
+ -- the Names bound, but separately; revert the envt
+ ; ((segs', thing), fvs) <- setLocalRdrEnv orig_lcl_env $
+ go orig_lcl_env new_bndrs segs
+
+ -- Figure out which of the bound names are used
+ ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
+ ; return ((used_bndrs, segs', thing), fvs) }
+
+ ; let seg' = (stmts', bndrs)
+ ; return (((seg':segs'), thing),
+ delListFromNameSet fvs bndrs) }
+
+ par_ctxt = ParStmtCtxt ctxt
+
+ cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
+ dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
+ <+> quotes (ppr (head vs)))
+\end{code}