+-- wrapper that does both the left- and right-hand sides
+rn_rec_stmts_and_then :: [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 = do
+ -- (A) make the mini fixity env for all of the stmts
+ fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
+
+ -- (B) do the LHSes
+ new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
+
+ -- bring them and their fixities into scope
+ let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
+ bindLocalNamesFV_WithFixities bound_names fix_env $ do
+
+ -- (C) do the right-hand-sides and thing-inside
+ segs <- rn_rec_stmts bound_names new_lhs_and_fv
+ (result, result_fvs) <- cont segs
+
+ -- (D) warn about unusued binders
+ let unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` result_fvs)]
+ warnUnusedLocalBinds unused_bndrs
+
+ -- (E) return
+ return (result, result_fvs)
+
+
+-- get all the fixity decls in any Let stmt
+collectRecStmtsFixities l =
+ foldr (\ s -> \acc -> case s of
+ (L loc (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
+ foldr (\ sig -> \ acc -> case sig of
+ (L loc (FixSig s)) -> (L loc s) : acc
+ _ -> acc) acc sigs
+ _ -> acc) [] l
+
+-- left-hand sides
+
+rn_rec_stmt_lhs :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
+ -- these fixities need to be brought into scope with the names
+ -> LStmt RdrName
+ -- 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 Name RdrName, FreeVars)]
+
+rn_rec_stmt_lhs fix_env (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
+ -- this is actually correct
+ emptyFVs)]
+
+rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
+ = do
+ -- should the ctxt be MDo instead?
+ (pat', fv_pat) <- rnPat_LocalRec fix_env pat
+ return [(L loc (BindStmt pat' expr a b),
+ fv_pat)]
+
+rn_rec_stmt_lhs fix_env (L loc (LetStmt binds@(HsIPBinds _)))
+ = do { addErr (badIpBinds (ptext SLIT("an mdo expression")) binds)
+ ; failM }
+
+rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
+ = do binds' <- rnValBindsLHS fix_env binds
+ return [(L loc (LetStmt (HsValBinds binds')),
+ -- Warning: this is bogus; see function invariant
+ emptyFVs
+ )]
+
+rn_rec_stmt_lhs fix_env (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
+ = rn_rec_stmts_lhs fix_env stmts
+
+rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
+ = pprPanic "rn_rec_stmt" (ppr stmt)
+
+rn_rec_stmts_lhs :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
+ -- these fixities need to be brought into scope with the names
+ -> [LStmt RdrName]
+ -> RnM [(LStmtLR Name RdrName, FreeVars)]
+rn_rec_stmts_lhs fix_env stmts =
+ let boundNames = collectLStmtsBinders stmts
+ doc = text "In a recursive mdo-expression"
+ in do
+ -- First do error checking: we need to check for dups here because we
+ -- don't bind all of the variables from the Stmt at once
+ -- with bindLocatedLocals.
+ checkDupNames doc boundNames
+ mappM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> returnM (concat ls)
+
+
+-- right-hand-sides
+
+rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
projects / ghc-hetmet.git / blobdiff