X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=4d85e9016e69abd1e48f6095be6d7ab738605129;hb=5b7e2a875b089f31cd8dedb52d47ef9a93f276be;hp=97c70e5dcd34bbff3bfaeb2a97f54a4c5a5f6213;hpb=081963e17719aa55d28f811fd1a152c4f7e75843;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 97c70e5..4d85e90 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -16,7 +16,7 @@ import SrcLoc
 import ErrUtils
 import Name
 import Bag
-import Var
+import Id
 import VarSet
 import Data.List
 import FastString
@@ -26,6 +26,7 @@ import TyCon
 import FiniteMap
 
 import Data.Array
+import Data.Maybe
 import System.IO   (FilePath)
 import System.Directory ( createDirectoryIfMissing )
 
@@ -61,12 +62,20 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do
 
   if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
 
+  -- Now, we try look for a file generated from a .hsc file to a .hs file, by peeking ahead.
+
+  let top_pos = catMaybes $ foldrBag (\ (L pos _) rest -> srcSpanFileName_maybe pos : rest) [] binds
+  let orig_file2 = case top_pos of
+		     (file_name:_) 
+		       | ".hsc" `isSuffixOf` unpackFS file_name -> unpackFS file_name
+		     _ -> orig_file
+
   let mod_name = moduleNameString (moduleName mod)
 
   let (binds1,_,st)
 		 = unTM (addTickLHsBinds binds) 
 		   (TTE
-		       { fileName    = mkFastString orig_file
+		       { fileName    = mkFastString orig_file2
 		      , declPath     = []
                       , inScope      = emptyVarSet
 		      , blackList    = listToFM [ (getSrcSpan (tyConName tyCon),()) 
@@ -89,14 +98,14 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do
 
      let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
      createDirectoryIfMissing True hpc_mod_dir
-     modTime <- getModificationTime orig_file
+     modTime <- getModificationTime orig_file2
      let entries' = [ (hpcPos, box) 
                     | (span,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
      when (length entries' /= tickBoxCount st) $ do
        panic "the number of .mix entries are inconsistent"
-     let hashNo = mixHash orig_file modTime tabStop entries'
+     let hashNo = mixHash orig_file2 modTime tabStop entries'
      mixCreate hpc_mod_dir mod_name 
-     	       $ Mix orig_file modTime (toHash hashNo) tabStop entries'
+     	       $ Mix orig_file2 modTime (toHash hashNo) tabStop entries'
      return $ hashNo 
    else do
      return $ 0
@@ -238,9 +247,9 @@ addTickLHsExprOptAlt oneOfMany (L pos e0)
         addTickHsExpr e0
 
 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
-addBinTickLHsExpr boxLabel (L pos e0) = do
-    e1 <- addTickHsExpr e0
-    allocBinTickBox boxLabel $ L pos e1
+addBinTickLHsExpr boxLabel (L pos e0) =
+    allocBinTickBox boxLabel pos $
+        addTickHsExpr e0
 
 addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
 addTickHsExpr e@(HsVar id) = do freeVar id; return e
@@ -635,7 +644,7 @@ getFileName = fileName `liftM` getEnv
 sameFileName :: SrcSpan -> TM a -> TM a -> TM a
 sameFileName pos out_of_scope in_scope = do
   file_name <- getFileName
-  case optSrcSpanFileName pos of 
+  case srcSpanFileName_maybe pos of 
     Just file_name2 
       | file_name == file_name2 -> in_scope
     _ -> out_of_scope
@@ -688,29 +697,28 @@ allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos =
      )
 allocATickBox _boxLabel _pos _fvs = return Nothing
 
-allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
-allocBinTickBox boxLabel (L pos e) | isGoodSrcSpan' pos = TM $ \ _env st ->
+allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
+                -> TM (LHsExpr Id)
+allocBinTickBox boxLabel pos m
+ | not opt_Hpc = allocTickBox (ExpBox False) pos m
+ | isGoodSrcSpan' pos =
+ do
+ e <- m
+ TM $ \ _env st ->
   let meT = (pos,[],boxLabel True)
       meF = (pos,[],boxLabel False)
       meE = (pos,[],ExpBox False)
       c = tickBoxCount st
       mes = mixEntries st
   in 
-     if opt_Hpc 
-        then ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
+             ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
            -- notice that F and T are reversed,
            -- because we are building the list in
            -- reverse...
              , noFVs
              , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
              )
-        else
-             ( L pos $ HsTick c [] $ L pos e
-             , noFVs
-             , st {tickBoxCount=c+1,mixEntries=meE:mes}
-             )
-
-allocBinTickBox _boxLabel e = return e
+allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
 
 isGoodSrcSpan' :: SrcSpan -> Bool
 isGoodSrcSpan' pos