Add tuple sections as a new feature

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

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index c110377..f31b2c8 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -24,10 +24,9 @@ import HscTypes
 import StaticFlags
 import TyCon
 import FiniteMap
+import Maybes
 
 import Data.Array
-import Data.Maybe
-import System.IO   (FilePath)
 import System.Directory ( createDirectoryIfMissing )
 
 import Trace.Hpc.Mix
@@ -247,9 +246,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
@@ -279,6 +278,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) 
@@ -302,17 +305,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 +377,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
@@ -697,29 +700,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