X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=f2abd30338c9e9db0886bdbff3e22f765c453ffc;hb=7a77f1b7a336d07749145d25763ccb587de17df1;hp=a8e774ef9dfdd49c868e30cf03a0d231887901d4;hpb=f5887bccdb537a011953576c4d106a37d371b69b;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index a8e774e..f2abd30 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -25,6 +25,8 @@ import FastString
 import HscTypes	
 import StaticFlags
 import UniqFM
+import Type
+import TyCon
 
 import Data.Array
 import System.Time (ClockTime(..))
@@ -125,10 +127,11 @@ 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
+addTickLHsBind bind | isDerivedLHsBind bind = do
+  return bind
+addTickLHsBind (L pos t@(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 (funBind@(FunBind { fun_id = (L _ id)  }))) = do 
   let name = getOccString id
   decl_path <- getPathEntry
@@ -177,6 +180,23 @@ addTickLHsBind (VarBind var_id var_rhs) = do
 -}
 addTickLHsBind other = return other
 
+-- This attempts to locate derived code, so as to not add ticks
+-- to compiler generated code. An alternative is to tie *all* the
+-- method functions to the deriving class name in the deriving list.
+
+-- This fuction works because we use the location of the datatype
+-- we are building the instance for as the location of derived code.
+
+isDerivedLHsBind :: LHsBind Id -> Bool
+isDerivedLHsBind (L pos t@(AbsBinds _ _ [(_,the_id,_,_)] _)) = 
+  case splitTyConApp_maybe (varType the_id) of
+    Just (tyCon,[ty]) | isClassTyCon tyCon ->
+	   case splitTyConApp_maybe ty of
+	     Just (tyCon',_) -> getSrcSpan (tyConName tyCon') == getSrcSpan the_id
+	     _ -> False
+    _ -> False
+isDerivedLHsBind _ = False
+
 -- Add a tick to the expression no matter what it is.  There is one exception:
 -- for the debugger, if the expression is a 'let', then we don't want to add
 -- a tick here because there will definititely be a tick on the body anyway.
@@ -276,10 +296,10 @@ addTickHsExpr (HsIf	 e1 e2 e3) =
 		(addTickLHsExprOptAlt True e2)
 		(addTickLHsExprOptAlt True e3)
 addTickHsExpr (HsLet binds e) =
+	bindLocals (map unLoc $ collectLocalBinders binds) $
 	liftM2 HsLet
-		(addTickHsLocalBinds binds)		-- to think about: !patterns.
-		(bindLocals (map unLoc $ collectLocalBinders binds) $
-                        addTickLHsExprNeverOrAlways e)
+		(addTickHsLocalBinds binds) -- to think about: !patterns.
+                (addTickLHsExprNeverOrAlways e)
 addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
         (stmts', last_exp') <- addTickLStmts' forQual stmts 
                                      (addTickLHsExpr last_exp)