From: Simon Marlow <simonmar@microsoft.com>
Date: Thu, 26 Apr 2007 15:16:15 +0000 (+0000)
Subject: fix scoping issues with mdo (test dynbrk004)
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f1915bd7bdb2d228c595d64713365c1394bfbd13

fix scoping issues with mdo (test dynbrk004)
---

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 4feb4f4..4fe4fab 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -266,12 +266,10 @@ addTickHsExpr (HsLet binds e) =
 		(addTickHsLocalBinds binds)		-- to think about: !patterns.
 		(bindLocals (map unLoc $ collectLocalBinders binds) $
                         addTickLHsExprNeverOrAlways e)
-addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
-	liftM4 HsDo
-		(return cxt)
-		(addTickLStmts forQual stmts)
-		(addTickLHsExpr last_exp)
-		(return srcloc)
+addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
+        (stmts', last_exp') <- addTickLStmts' forQual stmts 
+                                     (addTickLHsExpr last_exp)
+	return (HsDo cxt stmts' last_exp' srcloc)
   where
 	forQual = case cxt of
 		    ListComp -> Just QualBinBox
@@ -368,68 +366,59 @@ addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
 
 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
 addTickGRHS isOneOfMany (GRHS stmts expr) = do
-  (stmts',expr') <- addTickLStmts' (Just $ GuardBinBox) stmts []
+  (stmts',expr') <- addTickLStmts' (Just $ GuardBinBox) stmts
                         (if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
                                     else addTickLHsExprAlways expr)
   return $ GRHS stmts' expr'
 
 addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
 addTickLStmts isGuard stmts = do
-  (stmts',_) <- addTickLStmts' isGuard stmts [] (return ())
-  return stmts'
-
-addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id]
-               -> [LStmt Id] -> TM a -> TM ([LStmt Id], a)
-addTickLStmts' isGuard [] acc do_rhs = do
-  rhs <- do_rhs
-  return (reverse acc, rhs)
-addTickLStmts' isGuard (s:ss) acc do_rhs = do
-  (s', binders) <- addTickLStmt isGuard s
-  bindLocals binders $ addTickLStmts' isGuard ss (s':acc) do_rhs
-
-addTickLStmt isGuard (L pos stmt) = do
-  (stmt',vars) <- addTickStmt isGuard stmt
-  return (L pos stmt', vars)
-
-addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id, [Id])
+  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
+  return stmts
+
+addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a 
+               -> TM ([LStmt Id], a)
+addTickLStmts' isGuard lstmts res
+  = bindLocals binders $ do
+        lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
+        a <- res
+        return (lstmts', a)
+  where
+        binders = map unLoc (collectLStmtsBinders lstmts)
+
+addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
 addTickStmt isGuard (BindStmt pat e bind fail) = do
-	e <- liftM4 BindStmt
+	liftM4 BindStmt
 		(addTickLPat pat)
 		(addTickLHsExprAlways e)
 		(addTickSyntaxExpr hpcSrcSpan bind)
 		(addTickSyntaxExpr hpcSrcSpan fail)
-        return (e, collectPatBinders pat)
 addTickStmt isGuard (ExprStmt e bind' ty) = do
-	e <- liftM3 ExprStmt
+	liftM3 ExprStmt
 		(addTick e)
 		(addTickSyntaxExpr hpcSrcSpan bind')
 		(return ty)
-        return (e, [])
   where
    addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
              | otherwise          = addTickLHsExprAlways e
 
 addTickStmt isGuard (LetStmt binds) = do
-        let binders = map unLoc (collectLocalBinders binds)
-	e <- liftM LetStmt
-		(bindLocals binders $ addTickHsLocalBinds binds)
-        return (e, binders)
+	liftM LetStmt
+		(addTickHsLocalBinds binds)
 addTickStmt isGuard (ParStmt pairs) = do
-  	e <- liftM ParStmt (mapM process pairs)
-        return (e, [])
+  	liftM ParStmt (mapM process pairs)
   where
 	process (stmts,ids) = 
 		liftM2 (,) 
 			(addTickLStmts isGuard stmts)
 			(return ids)
 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
-  	e <- liftM5 RecStmt 
+  	liftM5 RecStmt 
 		(addTickLStmts isGuard stmts)
 		(return ids1)
 		(return ids2)
 		(return tys)
 		(addTickDictBinds dictbinds)
-        return (e,[])
 
 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 addTickHsLocalBinds (HsValBinds binds) =