X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=37cbc2d5c5c6dd4c4c29cc0e6efcfe79d8c5cb62;hb=7f2ce5cf1828ea3889ec8b67ecfb53b8431ad376;hp=57455c4818bf982e5aa6b8728ce00ac482314655;hpb=e01036f89a0d3949ea642dd42b29bc8e31658f0f;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 57455c4..37cbc2d 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -431,7 +431,7 @@ addTickLStmts' isGuard lstmts res
 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
 addTickStmt _isGuard (LastStmt e ret) = do
 	liftM2 LastStmt
-		(addTickLHsExprAlways e)
+		(addTickLHsExpr e)
 		(addTickSyntaxExpr hpcSrcSpan ret)
 addTickStmt _isGuard (BindStmt pat e bind fail) = do
 	liftM4 BindStmt
@@ -608,9 +608,12 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do
     binders = collectLocalBinders local_binds
 
 addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
-addTickCmdGRHS (GRHS stmts cmd) = do
-  (stmts',expr') <- addTickLCmdStmts' stmts (addTickLHsCmd cmd)
-  return $ GRHS stmts' expr'
+-- The *guards* are *not* Cmds, although the body is
+-- C.f. addTickGRHS for the BinBox stuff
+addTickCmdGRHS (GRHS stmts cmd)
+  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) 
+                                   stmts (addTickLHsCmd cmd)
+       ; return $ GRHS stmts' expr' }
 
 addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
 addTickLCmdStmts stmts = do
@@ -633,6 +636,10 @@ addTickCmdStmt (BindStmt pat c bind fail) = do
 		(addTickLHsCmd c)
 		(return bind)
 		(return fail)
+addTickCmdStmt (LastStmt c ret) = do
+	liftM2 LastStmt
+		(addTickLHsCmd c)
+		(addTickSyntaxExpr hpcSrcSpan ret)
 addTickCmdStmt (ExprStmt c bind' guard' ty) = do
 	liftM4 ExprStmt
 		(addTickLHsCmd c)