Tidy up rebindable syntax for MDo

[ghc-hetmet.git] / compiler / deSugar / Coverage.lhs

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 21ce13d..b0e92bb 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -99,7 +99,7 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
      createDirectoryIfMissing True hpc_mod_dir
      modTime <- getModificationTime orig_file2
      let entries' = [ (hpcPos, box) 
-                    | (span,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
+                    | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
      when (length entries' /= tickBoxCount st) $ do
        panic "the number of .mix entries are inconsistent"
      let hashNo = mixHash orig_file2 modTime tabStop entries'
@@ -113,13 +113,16 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
   breakArray <- newBreakArray $ length entries
 
   let locsTicks = listArray (0,tickBoxCount st-1) 
-                     [ span | (span,_,_) <- entries ]
+                     [ span | (span,_,_,_) <- entries ]
       varsTicks = listArray (0,tickBoxCount st-1) 
-                     [ vars | (_,vars,_) <- entries ]
+                     [ vars | (_,_,vars,_) <- entries ]
+      declsTicks= listArray (0,tickBoxCount st-1) 
+                     [ decls | (_,decls,_,_) <- entries ]
       modBreaks = emptyModBreaks 
                   { modBreaks_flags = breakArray 
                   , modBreaks_locs  = locsTicks 
                   , modBreaks_vars  = varsTicks
+                  , modBreaks_decls = declsTicks
                   } 
 
   doIfSet_dyn dflags  Opt_D_dump_hpc $ do
@@ -286,8 +289,8 @@ addTickHsExpr (HsCase e mgs) =
        liftM2 HsCase
                (addTickLHsExpr e) 
                (addTickMatchGroup mgs)
-addTickHsExpr (HsIf     e1 e2 e3) = 
-       liftM3 HsIf
+addTickHsExpr (HsIf cnd e1 e2 e3) = 
+       liftM3 (HsIf cnd)
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsExprOptAlt True e2)
                (addTickLHsExprOptAlt True e3)
@@ -462,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
@@ -536,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
@@ -670,11 +668,11 @@ allocTickBox boxLabel pos m | isGoodSrcSpan' pos =
   sameFileName pos 
     (do e <- m; return (L pos e)) $ do
   (fvs, e) <- getFreeVars m
-  TM $ \ _env st ->
+  TM $ \ env st ->
     let c = tickBoxCount st
         ids = occEnvElts fvs
         mes = mixEntries st
-        me = (pos, map (nameOccName.idName) ids, boxLabel)
+        me = (pos, declPath env, map (nameOccName.idName) ids, boxLabel)
     in
     ( L pos (HsTick c ids (L pos e))
     , fvs
@@ -687,8 +685,11 @@ allocTickBox _boxLabel pos m = do e <- m; return (L pos e)
 allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
 allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = 
   sameFileName pos 
-    (return Nothing) $ TM $ \ _env st ->
-  let me = (pos, map (nameOccName.idName) ids, boxLabel)
+    (return Nothing) $ TM $ \ env st ->
+  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
@@ -705,10 +706,10 @@ allocBinTickBox boxLabel pos m
  | isGoodSrcSpan' pos =
  do
  e <- m
- TM $ \ _env st ->
-  let meT = (pos,[],boxLabel True)
-      meF = (pos,[],boxLabel False)
-      meE = (pos,[],ExpBox False)
+ TM $ \ env st ->
+  let meT = (pos,declPath env, [],boxLabel True)
+      meF = (pos,declPath env, [],boxLabel False)
+      meE = (pos,declPath env, [],ExpBox False)
       c = tickBoxCount st
       mes = mixEntries st
   in 
@@ -757,7 +758,7 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
 
 
 \begin{code}
-type MixEntry_ = (SrcSpan, [OccName], BoxLabel)
+type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
 
 -- For the hash value, we hash everything: the file name, 
 --  the timestamp of the original source file, the tab stop,