X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=21ce13dbe3c70fc1f6404e6fd7de2d0d5f56926f;hb=edeee10702955ca3c53444f2f328b4cce0ab3e32;hp=52c0f04b53a032043b0a43885fd1df049ea8e232;hpb=eb8117f959ee0e109dbb8a9b500bcac2eb7871dc;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 52c0f04..21ce13d 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -23,7 +23,7 @@ import FastString
 import HscTypes	
 import StaticFlags
 import TyCon
-import FiniteMap
+import MonadUtils
 import Maybes
 
 import Data.Array
@@ -34,6 +34,8 @@ import Trace.Hpc.Util
 
 import BreakArray 
 import Data.HashTable   ( hashString )
+import Data.Map (Map)
+import qualified Data.Map as Map
 \end{code}
 
 
@@ -75,8 +77,8 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
 		       { fileName    = mkFastString orig_file2
 		      , declPath     = []
                       , inScope      = emptyVarSet
-		      , blackList    = listToFM [ (getSrcSpan (tyConName tyCon),()) 
-		      		       		| tyCon <- tyCons ]
+		      , blackList    = Map.fromList [ (getSrcSpan (tyConName tyCon),()) 
+		                                    | tyCon <- tyCons ]
 		       })
 		   (TT 
 		      { tickBoxCount = 0
@@ -137,9 +139,9 @@ addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
 addTickLHsBinds binds = mapBagM addTickLHsBind binds
 
 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
-addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
-  abs_binds' <- addTickLHsBinds abs_binds
-  return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
+addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds })) = do
+  binds' <- addTickLHsBinds binds
+  return $ L pos $ bind { abs_binds = binds' }
 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do 
   let name = getOccString id
   decl_path <- getPathEntry
@@ -290,7 +292,7 @@ addTickHsExpr (HsIf	 e1 e2 e3) =
 		(addTickLHsExprOptAlt True e2)
 		(addTickLHsExprOptAlt True e3)
 addTickHsExpr (HsLet binds e) =
-	bindLocals (map unLoc $ collectLocalBinders binds) $
+	bindLocals (collectLocalBinders binds) $
 	liftM2 HsLet
 		(addTickHsLocalBinds binds) -- to think about: !patterns.
                 (addTickLHsExprNeverOrAlways e)
@@ -398,7 +400,7 @@ addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
     guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
     return $ GRHSs guarded' local_binds'
   where
-    binders = map unLoc (collectLocalBinders local_binds)
+    binders = collectLocalBinders local_binds
 
 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
 addTickGRHS isOneOfMany (GRHS stmts expr) = do
@@ -420,7 +422,7 @@ addTickLStmts' isGuard lstmts res
         a <- res
         return (lstmts', a)
   where
-        binders = map unLoc (collectLStmtsBinders lstmts)
+        binders = collectLStmtsBinders lstmts
 
 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
 addTickStmt _isGuard (BindStmt pat e bind fail) = do
@@ -440,31 +442,27 @@ addTickStmt _isGuard (LetStmt binds) = do
 addTickStmt isGuard (ParStmt pairs) = do
     liftM ParStmt 
         (mapM (addTickStmtAndBinders isGuard) pairs)
-addTickStmt isGuard (TransformStmt (stmts, ids) usingExpr maybeByExpr) = do
-    liftM3 TransformStmt 
-        (addTickStmtAndBinders isGuard (stmts, ids))
+
+addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do
+    liftM4 TransformStmt 
+        (addTickLStmts isGuard stmts)
+        (return ids)
         (addTickLHsExprAlways usingExpr)
         (addTickMaybeByLHsExpr maybeByExpr)
-addTickStmt isGuard (GroupStmt (stmts, binderMap) groupByClause) = do
-    liftM2 GroupStmt 
-        (addTickStmtAndBinders isGuard (stmts, binderMap))
-        (case groupByClause of
-            GroupByNothing usingExpr -> addTickLHsExprAlways usingExpr >>= (return . GroupByNothing)
-            GroupBySomething eitherUsingExpr byExpr -> do
-                eitherUsingExpr' <- mapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) eitherUsingExpr
-                byExpr' <- addTickLHsExprAlways byExpr
-                return $ GroupBySomething eitherUsingExpr' byExpr')
-    where
-        mapEitherM f g x = do
-          case x of
-            Left a -> f a >>= (return . Left)
-            Right b -> g b >>= (return . Right)
+
+addTickStmt isGuard (GroupStmt stmts binderMap by using) = do
+    liftM4 GroupStmt 
+        (addTickLStmts isGuard stmts)
+        (return binderMap)
+        (fmapMaybeM  addTickLHsExprAlways by)
+	(fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
+
 addTickStmt isGuard stmt@(RecStmt {})
   = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
-       ; dicts' <- addTickDictBinds (recS_dicts stmt)
+       ; dicts' <- addTickEvBinds (recS_dicts stmt)
        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
                       , recS_mfix_fn = mfix', recS_bind_fn = bind'
                       , recS_dicts = dicts' }) }
@@ -510,7 +508,7 @@ addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
 	liftM2 IPBinds
 		(mapM (liftL (addTickIPBind)) ipbinds)
-		(addTickDictBinds dictbinds)
+		(return dictbinds)
 
 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 addTickIPBind (IPBind nm e) =
@@ -538,8 +536,8 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 addTickLHsCmd x = addTickLHsExpr x
 
-addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
-addTickDictBinds x = addTickLHsBinds x
+addTickEvBinds :: TcEvBinds -> TM TcEvBinds
+addTickEvBinds x = return x   -- No coverage testing for dictionary binding
 
 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 addTickHsRecordBinds (HsRecFields fields dd) 
@@ -577,7 +575,7 @@ data TickTransState = TT { tickBoxCount:: Int
 data TickTransEnv = TTE { fileName      :: FastString
 			, declPath     :: [String]
                         , inScope      :: VarSet
-			, blackList   :: FiniteMap SrcSpan ()
+			, blackList   :: Map SrcSpan ()
 			}
 
 --	deriving Show
@@ -661,7 +659,7 @@ bindLocals new_ids (TM m)
 
 isBlackListed :: SrcSpan -> TM Bool
 isBlackListed pos = TM $ \ env st -> 
-	      case lookupFM (blackList env) pos of
+	      case Map.lookup pos (blackList env) of
 	        Nothing -> (False,noFVs,st)
 		Just () -> (True,noFVs,st)