From: andy@galois.com <unknown>
Date: Wed, 1 Nov 2006 23:08:27 +0000 (+0000)
Subject: Fixing Alts to reflect Alternatives, rather than every pattern match in Hpc.
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=859001105a5cbb15959f04519911da86e597f2e1

Fixing Alts to reflect Alternatives, rather than every pattern match in Hpc.
---

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 36b0404..68bd17f 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -122,7 +122,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  })))  = do
   let arg_count = matchGroupArity mg
   let (tys,res_ty) = splitFunTysN arg_count ty
 
-  return $ L pos $ funBind { fun_matches = MatchGroup ({-L pos fn_entry:-}matches') ty 
+  return $ L pos $ funBind { fun_matches = MatchGroup matches' ty 
 			   , fun_tick = tick_no
 			   }
 
@@ -289,7 +289,7 @@ addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
 addTickHsExpr (HsTick _ _) = error "addTickhsExpr: HsTick _ _"
 
 addTickMatchGroup (MatchGroup matches ty) = do
-  let isOneOfMany = True -- AJG: for now
+  let isOneOfMany = matchesOneOfMany matches
   matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
   return $ MatchGroup matches' ty
 
@@ -514,6 +514,14 @@ hpcLoc = L hpcSrcSpan
 
 
 \begin{code}
+matchesOneOfMany :: [LMatch Id] -> Bool
+matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
+  where
+	matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
+\end{code}
+
+
+\begin{code}
 ---------------------------------------------------------------
 -- Datatypes and file-access routines for the per-module (.mix)
 -- indexes used by Hpc.