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 6bdc8a1..b0e92bb 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -23,7 +23,6 @@ import FastString
 import HscTypes        
 import StaticFlags
 import TyCon
-import FiniteMap
 import MonadUtils
 import Maybes
 
@@ -35,6 +34,8 @@ import Trace.Hpc.Util
 
 import BreakArray 
 import Data.HashTable   ( hashString )
+import Data.Map (Map)
+import qualified Data.Map as Map
 \end{code}
 
 
@@ -76,8 +77,8 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
                       { fileName    = mkFastString orig_file2
                      , declPath     = []
                       , inScope      = emptyVarSet
-                     , blackList    = listToFM [ (getSrcSpan (tyConName tyCon),()) 
-                                               | tyCon <- tyCons ]
+                     , blackList    = Map.fromList [ (getSrcSpan (tyConName tyCon),()) 
+                                                   | tyCon <- tyCons ]
                       })
                   (TT 
                      { tickBoxCount = 0
@@ -98,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'
@@ -112,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
@@ -138,9 +142,9 @@ addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
 addTickLHsBinds binds = mapBagM addTickLHsBind binds
 
 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
-addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
-  abs_binds' <- addTickLHsBinds abs_binds
-  return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
+addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds })) = do
+  binds' <- addTickLHsBinds binds
+  return $ L pos $ bind { abs_binds = binds' }
 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do 
   let name = getOccString id
   decl_path <- getPathEntry
@@ -285,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)
@@ -461,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' <- addTickDictBinds (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
@@ -507,7 +509,7 @@ addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
        liftM2 IPBinds
                (mapM (liftL (addTickIPBind)) ipbinds)
-               (addTickDictBinds dictbinds)
+               (return dictbinds)
 
 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 addTickIPBind (IPBind nm e) =
@@ -535,9 +537,6 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 addTickLHsCmd x = addTickLHsExpr x
 
-addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
-addTickDictBinds x = addTickLHsBinds x
-
 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 addTickHsRecordBinds (HsRecFields fields dd) 
   = do { fields' <- mapM process fields
@@ -574,7 +573,7 @@ data TickTransState = TT { tickBoxCount:: Int
 data TickTransEnv = TTE { fileName      :: FastString
                        , declPath     :: [String]
                         , inScope      :: VarSet
-                       , blackList   :: FiniteMap SrcSpan ()
+                       , blackList   :: Map SrcSpan ()
                        }
 
 --     deriving Show
@@ -658,7 +657,7 @@ bindLocals new_ids (TM m)
 
 isBlackListed :: SrcSpan -> TM Bool
 isBlackListed pos = TM $ \ env st -> 
-             case lookupFM (blackList env) pos of
+             case Map.lookup pos (blackList env) of
                Nothing -> (False,noFVs,st)
                Just () -> (True,noFVs,st)
 
@@ -669,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
@@ -686,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
@@ -704,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 
@@ -756,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,