X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=6bdc8a178ca4fbf3aeaa19f0070d27efe9e1de45;hb=48f550f99f6f82f26de79529cf256b1e0a2b8e88;hp=4d85e9016e69abd1e48f6095be6d7ab738605129;hpb=cf1ad64a25ef115db6f34837137a4180714baf76;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 4d85e90..6bdc8a1 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -11,7 +11,7 @@ import HsSyn
 import Module
 import Outputable
 import DynFlags
-import Monad		
+import Control.Monad
 import SrcLoc
 import ErrUtils
 import Name
@@ -24,10 +24,10 @@ import HscTypes
 import StaticFlags
 import TyCon
 import FiniteMap
+import MonadUtils
+import Maybes
 
 import Data.Array
-import Data.Maybe
-import System.IO   (FilePath)
 import System.Directory ( createDirectoryIfMissing )
 
 import Trace.Hpc.Mix
@@ -53,12 +53,10 @@ addCoverageTicksToBinds
         -> LHsBinds Id
         -> IO (LHsBinds Id, HpcInfo, ModBreaks)
 
-addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do 
-
-  let orig_file = 
-             case ml_hs_file mod_loc of
-		    Just file -> file
-		    Nothing -> panic "can not find the original file during hpc trans"
+addCoverageTicksToBinds dflags mod mod_loc tyCons binds = 
+ case ml_hs_file mod_loc of
+ Nothing -> return (binds, emptyHpcInfo False, emptyModBreaks)
+ Just orig_file -> do
 
   if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
 
@@ -279,6 +277,10 @@ addTickHsExpr (SectionR e1 e2) =
 	liftM2 SectionR
 		(addTickLHsExpr e1)
 		(addTickLHsExpr e2)
+addTickHsExpr (ExplicitTuple es boxity) =
+        liftM2 ExplicitTuple
+                (mapM addTickTupArg es)
+                (return boxity)
 addTickHsExpr (HsCase e mgs) = 
 	liftM2 HsCase
 		(addTickLHsExpr e) 
@@ -289,7 +291,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)
@@ -302,17 +304,13 @@ addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
 		    ListComp -> Just $ BinBox QualBinBox
 		    _        -> Nothing
 addTickHsExpr (ExplicitList ty es) = 
-	liftM2 ExplicitList 
+	liftM2 ExplicitList
 		(return ty)
 		(mapM (addTickLHsExpr) es)
 addTickHsExpr (ExplicitPArr ty es) =
 	liftM2 ExplicitPArr
 		(return ty)
 		(mapM (addTickLHsExpr) es)
-addTickHsExpr (ExplicitTuple es box) =
-	liftM2 ExplicitTuple
-		(mapM (addTickLHsExpr) es)
-		(return box)
 addTickHsExpr (RecordCon id ty rec_binds) = 
 	liftM3 RecordCon
 		(return id)
@@ -378,6 +376,10 @@ addTickHsExpr e@(HsType _) = return e
 -- Others dhould never happen in expression content.
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
 
+addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
+addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
+addTickTupArg (Missing ty) = return (Missing ty)
+
 addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
 addTickMatchGroup (MatchGroup matches ty) = do
   let isOneOfMany = matchesOneOfMany matches
@@ -397,7 +399,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
@@ -419,7 +421,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
@@ -439,32 +441,30 @@ 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 (RecStmt stmts ids1 ids2 tys dictbinds) = do
-  	liftM5 RecStmt 
-		(addTickLStmts isGuard stmts)
-		(return ids1)
-		(return ids2)
-		(return tys)
-		(addTickDictBinds dictbinds)
+
+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)
+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+                      , recS_mfix_fn = mfix', recS_bind_fn = bind'
+                      , recS_dicts = dicts' }) }
 
 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
@@ -737,9 +737,9 @@ mkHpcPos pos
    start = srcSpanStart pos
    end   = srcSpanEnd pos
    hpcPos = toHpcPos ( srcLocLine start
-		     , srcLocCol start + 1
+		     , srcLocCol start
 		     , srcLocLine end
-		     , srcLocCol end
+		     , srcLocCol end - 1
 		     )
 
 hpcSrcSpan :: SrcSpan