X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FdeSugar%2FCoverage.lhs;h=b0e92bb20ea0ea72ab0e26038cc68cb230bc1675;hb=ba05282d3915e7051b3f016366b971a8506b0093;hp=2d8afbd7ad1b5c5333f8e387cefb26fe9fd144eb;hpb=e6396ceaf29d592785944ca9f4086595d1137836;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 2d8afbd..b0e92bb 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -465,10 +465,8 @@ addTickStmt isGuard stmt@(RecStmt {})
        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn 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' }) }
+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
 
 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
@@ -539,9 +537,6 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 addTickLHsCmd x = addTickLHsExpr 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) 
   = do	{ fields' <- mapM process fields
@@ -691,7 +686,10 @@ allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
 allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = 
   sameFileName pos 
     (return Nothing) $ TM $ \ env st ->
-  let me = (pos, declPath env, map (nameOccName.idName) ids, boxLabel)
+  let mydecl_path
+        | null (declPath env), TopLevelBox x <- boxLabel = x
+        | otherwise = declPath env
+      me = (pos, mydecl_path, map (nameOccName.idName) ids, boxLabel)
       c = tickBoxCount st
       mes = mixEntries st
       ids = occEnvElts fvs