X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=fbe1ab9a4537e46489900aadd560d0449764943e;hp=8071da756f4c01908e5f28539a77fd30da3b0a9a;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=3bb700d515de2405fa5db3326482e529f332d508

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 8071da7..fbe1ab9 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -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
@@ -843,26 +846,16 @@ allocBinTickBox boxLabel pos m
 allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
 
 isGoodSrcSpan' :: SrcSpan -> Bool
-isGoodSrcSpan' pos
-   | not (isGoodSrcSpan pos) = False
-   | start == end            = False
-   | otherwise		     = True
-  where
-   start = srcSpanStart pos
-   end   = srcSpanEnd pos
+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
+isGoodSrcSpan' (UnhelpfulSpan _) = False
 
 mkHpcPos :: SrcSpan -> HpcPos
-mkHpcPos pos 
-   | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
-   | otherwise		      = hpcPos
-  where
-   start = srcSpanStart pos
-   end   = srcSpanEnd pos
-   hpcPos = toHpcPos ( srcLocLine start
-		     , srcLocCol start
-		     , srcLocLine end
-		     , srcLocCol end - 1
-		     )
+mkHpcPos pos@(RealSrcSpan s)
+   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
+                                    srcSpanStartCol s,
+                                    srcSpanEndLine s,
+                                    srcSpanEndCol s)
+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
 
 hpcSrcSpan :: SrcSpan
 hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")