compiler/deSugar/Coverage.lhs

   1 %
   2 % (c) Galois, 2006
   3 % (c) University of Glasgow, 2007
   4 %
   5 \section[Coverage]{@coverage@: the main function}
   6
   7 \begin{code}
   8 module Coverage (addCoverageTicksToBinds) where
   9
  10 import HsSyn
  11 import Module
  12 import Outputable
  13 import DynFlags
  14 import Control.Monad
  15 import SrcLoc
  16 import ErrUtils
  17 import Name
  18 import Bag
  19 import Id
  20 import VarSet
  21 import Data.List
  22 import FastString
  23 import HscTypes
  24 import StaticFlags
  25 import TyCon
  26 import FiniteMap
  27 import Maybes
  28
  29 import Data.Array
  30 import System.Directory ( createDirectoryIfMissing )
  31
  32 import Trace.Hpc.Mix
  33 import Trace.Hpc.Util
  34
  35 import BreakArray
  36 import Data.HashTable   ( hashString )
  37 \end{code}
  38
  39
  40 %************************************************************************
  41 %*                                                                      *
  42 %*              The main function: addCoverageTicksToBinds
  43 %*                                                                      *
  44 %************************************************************************
  45
  46 \begin{code}
  47 addCoverageTicksToBinds
  48         :: DynFlags
  49         -> Module
  50         -> ModLocation          -- of the current module
  51         -> [TyCon]              -- type constructor in this module
  52         -> LHsBinds Id
  53         -> IO (LHsBinds Id, HpcInfo, ModBreaks)
  54
  55 addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
  56  case ml_hs_file mod_loc of
  57  Nothing -> return (binds, emptyHpcInfo False, emptyModBreaks)
  58  Just orig_file -> do
  59
  60   if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
  61
  62   -- Now, we try look for a file generated from a .hsc file to a .hs file, by peeking ahead.
  63
  64   let top_pos = catMaybes $ foldrBag (\ (L pos _) rest -> srcSpanFileName_maybe pos : rest) [] binds
  65   let orig_file2 = case top_pos of
  66                      (file_name:_)
  67                        | ".hsc" `isSuffixOf` unpackFS file_name -> unpackFS file_name
  68                      _ -> orig_file
  69
  70   let mod_name = moduleNameString (moduleName mod)
  71
  72   let (binds1,_,st)
  73                  = unTM (addTickLHsBinds binds)
  74                    (TTE
  75                        { fileName    = mkFastString orig_file2
  76                       , declPath     = []
  77                       , inScope      = emptyVarSet
  78                       , blackList    = listToFM [ (getSrcSpan (tyConName tyCon),())
  79                                                 | tyCon <- tyCons ]
  80                        })
  81                    (TT
  82                       { tickBoxCount = 0
  83                       , mixEntries   = []
  84                       })
  85
  86   let entries = reverse $ mixEntries st
  87
  88   -- write the mix entries for this module
  89   hashNo <- if opt_Hpc then do
  90      let hpc_dir = hpcDir dflags
  91
  92      let hpc_mod_dir = if modulePackageId mod == mainPackageId
  93                        then hpc_dir
  94                        else hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)
  95
  96      let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
  97      createDirectoryIfMissing True hpc_mod_dir
  98      modTime <- getModificationTime orig_file2
  99      let entries' = [ (hpcPos, box)
 100                     | (span,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
 101      when (length entries' /= tickBoxCount st) $ do
 102        panic "the number of .mix entries are inconsistent"
 103      let hashNo = mixHash orig_file2 modTime tabStop entries'
 104      mixCreate hpc_mod_dir mod_name
 105                $ Mix orig_file2 modTime (toHash hashNo) tabStop entries'
 106      return $ hashNo
 107    else do
 108      return $ 0
 109
 110   -- Todo: use proper src span type
 111   breakArray <- newBreakArray $ length entries
 112
 113   let locsTicks = listArray (0,tickBoxCount st-1)
 114                      [ span | (span,_,_) <- entries ]
 115       varsTicks = listArray (0,tickBoxCount st-1)
 116                      [ vars | (_,vars,_) <- entries ]
 117       modBreaks = emptyModBreaks
 118                   { modBreaks_flags = breakArray
 119                   , modBreaks_locs  = locsTicks
 120                   , modBreaks_vars  = varsTicks
 121                   }
 122
 123   doIfSet_dyn dflags  Opt_D_dump_hpc $ do
 124           printDump (pprLHsBinds binds1)
 125
 126   return (binds1, HpcInfo (tickBoxCount st) hashNo, modBreaks)
 127 \end{code}
 128
 129
 130 \begin{code}
 131 liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
 132 liftL f (L loc a) = do
 133   a' <- f a
 134   return $ L loc a'
 135
 136 addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
 137 addTickLHsBinds binds = mapBagM addTickLHsBind binds
 138
 139 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
 140 addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
 141   abs_binds' <- addTickLHsBinds abs_binds
 142   return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
 143 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
 144   let name = getOccString id
 145   decl_path <- getPathEntry
 146
 147   (fvs, (MatchGroup matches' ty)) <-
 148         getFreeVars $
 149         addPathEntry name $
 150         addTickMatchGroup (fun_matches funBind)
 151
 152   blackListed <- isBlackListed pos
 153
 154   -- Todo: we don't want redundant ticks on simple pattern bindings
 155   -- We don't want to generate code for blacklisted positions
 156   if blackListed || (not opt_Hpc && isSimplePatBind funBind)
 157      then
 158         return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
 159                                  , fun_tick = Nothing
 160                                  }
 161      else do
 162         tick_no <- allocATickBox (if null decl_path
 163                                      then TopLevelBox [name]
 164                                      else LocalBox (decl_path ++ [name]))
 165                                 pos fvs
 166
 167         return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
 168                                  , fun_tick = tick_no
 169                                  }
 170    where
 171    -- a binding is a simple pattern binding if it is a funbind with zero patterns
 172    isSimplePatBind :: HsBind a -> Bool
 173    isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
 174
 175 -- TODO: Revisit this
 176 addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
 177   let name = "(...)"
 178   rhs' <- addPathEntry name $ addTickGRHSs False rhs
 179 {-
 180   decl_path <- getPathEntry
 181   tick_me <- allocTickBox (if null decl_path
 182                            then TopLevelBox [name]
 183                            else LocalBox (name : decl_path))
 184 -}
 185   return $ L pos $ pat { pat_rhs = rhs' }
 186
 187 -- Only internal stuff, not from source, uses VarBind, so we ignore it.
 188 addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
 189
 190 -- Add a tick to the expression no matter what it is.  There is one exception:
 191 -- for the debugger, if the expression is a 'let', then we don't want to add
 192 -- a tick here because there will definititely be a tick on the body anyway.
 193 addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id)
 194 addTickLHsExprAlways (L pos e0)
 195   | not opt_Hpc, HsLet _ _ <- e0 = addTickLHsExprNever (L pos e0)
 196   | otherwise = allocTickBox (ExpBox False) pos $ addTickHsExpr e0
 197
 198 addTickLHsExprNeverOrAlways :: LHsExpr Id -> TM (LHsExpr Id)
 199 addTickLHsExprNeverOrAlways e
 200     | opt_Hpc   = addTickLHsExprNever e
 201     | otherwise = addTickLHsExprAlways e
 202
 203 addTickLHsExprNeverOrMaybe :: LHsExpr Id -> TM (LHsExpr Id)
 204 addTickLHsExprNeverOrMaybe e
 205     | opt_Hpc   = addTickLHsExprNever e
 206     | otherwise = addTickLHsExpr e
 207
 208 -- version of addTick that does not actually add a tick,
 209 -- because the scope of this tick is completely subsumed by
 210 -- another.
 211 addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
 212 addTickLHsExprNever (L pos e0) = do
 213     e1 <- addTickHsExpr e0
 214     return $ L pos e1
 215
 216 -- selectively add ticks to interesting expressions
 217 addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
 218 addTickLHsExpr (L pos e0) = do
 219     if opt_Hpc || isGoodBreakExpr e0
 220        then do
 221           allocTickBox (ExpBox False) pos $ addTickHsExpr e0
 222        else do
 223           e1 <- addTickHsExpr e0
 224           return $ L pos e1
 225
 226 -- general heuristic: expressions which do not denote values are good break points
 227 isGoodBreakExpr :: HsExpr Id -> Bool
 228 isGoodBreakExpr (HsApp {})     = True
 229 isGoodBreakExpr (OpApp {})     = True
 230 isGoodBreakExpr (NegApp {})    = True
 231 isGoodBreakExpr (HsCase {})    = True
 232 isGoodBreakExpr (HsIf {})      = True
 233 isGoodBreakExpr (RecordCon {}) = True
 234 isGoodBreakExpr (RecordUpd {}) = True
 235 isGoodBreakExpr (ArithSeq {})  = True
 236 isGoodBreakExpr (PArrSeq {})   = True
 237 isGoodBreakExpr _other         = False
 238
 239 addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
 240 addTickLHsExprOptAlt oneOfMany (L pos e0)
 241   | not opt_Hpc = addTickLHsExpr (L pos e0)
 242   | otherwise =
 243     allocTickBox (ExpBox oneOfMany) pos $
 244         addTickHsExpr e0
 245
 246 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 247 addBinTickLHsExpr boxLabel (L pos e0) =
 248     allocBinTickBox boxLabel pos $
 249         addTickHsExpr e0
 250
 251 addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
 252 addTickHsExpr e@(HsVar id) = do freeVar id; return e
 253 addTickHsExpr e@(HsIPVar _) = return e
 254 addTickHsExpr e@(HsOverLit _) = return e
 255 addTickHsExpr e@(HsLit _) = return e
 256 addTickHsExpr (HsLam matchgroup) =
 257         liftM HsLam (addTickMatchGroup matchgroup)
 258 addTickHsExpr (HsApp e1 e2) =
 259         liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
 260 addTickHsExpr (OpApp e1 e2 fix e3) =
 261         liftM4 OpApp
 262                 (addTickLHsExpr e1)
 263                 (addTickLHsExprNever e2)
 264                 (return fix)
 265                 (addTickLHsExpr e3)
 266 addTickHsExpr (NegApp e neg) =
 267         liftM2 NegApp
 268                 (addTickLHsExpr e)
 269                 (addTickSyntaxExpr hpcSrcSpan neg)
 270 addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExprNeverOrMaybe e)
 271 addTickHsExpr (SectionL e1 e2) =
 272         liftM2 SectionL
 273                 (addTickLHsExpr e1)
 274                 (addTickLHsExpr e2)
 275 addTickHsExpr (SectionR e1 e2) =
 276         liftM2 SectionR
 277                 (addTickLHsExpr e1)
 278                 (addTickLHsExpr e2)
 279 addTickHsExpr (ExplicitTuple es boxity) =
 280         liftM2 ExplicitTuple
 281                 (mapM addTickTupArg es)
 282                 (return boxity)
 283 addTickHsExpr (HsCase e mgs) =
 284         liftM2 HsCase
 285                 (addTickLHsExpr e)
 286                 (addTickMatchGroup mgs)
 287 addTickHsExpr (HsIf      e1 e2 e3) =
 288         liftM3 HsIf
 289                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
 290                 (addTickLHsExprOptAlt True e2)
 291                 (addTickLHsExprOptAlt True e3)
 292 addTickHsExpr (HsLet binds e) =
 293         bindLocals (map unLoc $ collectLocalBinders binds) $
 294         liftM2 HsLet
 295                 (addTickHsLocalBinds binds) -- to think about: !patterns.
 296                 (addTickLHsExprNeverOrAlways e)
 297 addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
 298         (stmts', last_exp') <- addTickLStmts' forQual stmts
 299                                      (addTickLHsExpr last_exp)
 300         return (HsDo cxt stmts' last_exp' srcloc)
 301   where
 302         forQual = case cxt of
 303                     ListComp -> Just $ BinBox QualBinBox
 304                     _        -> Nothing
 305 addTickHsExpr (ExplicitList ty es) =
 306         liftM2 ExplicitList
 307                 (return ty)
 308                 (mapM (addTickLHsExpr) es)
 309 addTickHsExpr (ExplicitPArr ty es) =
 310         liftM2 ExplicitPArr
 311                 (return ty)
 312                 (mapM (addTickLHsExpr) es)
 313 addTickHsExpr (RecordCon id ty rec_binds) =
 314         liftM3 RecordCon
 315                 (return id)
 316                 (return ty)
 317                 (addTickHsRecordBinds rec_binds)
 318 addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
 319         liftM5 RecordUpd
 320                 (addTickLHsExpr e)
 321                 (addTickHsRecordBinds rec_binds)
 322                 (return cons) (return tys1) (return tys2)
 323
 324 addTickHsExpr (ExprWithTySigOut e ty) =
 325         liftM2 ExprWithTySigOut
 326                 (addTickLHsExprNever e) -- No need to tick the inner expression
 327                                     -- for expressions with signatures
 328                 (return ty)
 329 addTickHsExpr (ArithSeq  ty arith_seq) =
 330         liftM2 ArithSeq
 331                 (return ty)
 332                 (addTickArithSeqInfo arith_seq)
 333 addTickHsExpr (HsTickPragma _ (L pos e0)) = do
 334     e2 <- allocTickBox (ExpBox False) pos $
 335                 addTickHsExpr e0
 336     return $ unLoc e2
 337 addTickHsExpr (PArrSeq   ty arith_seq) =
 338         liftM2 PArrSeq
 339                 (return ty)
 340                 (addTickArithSeqInfo arith_seq)
 341 addTickHsExpr (HsSCC nm e) =
 342         liftM2 HsSCC
 343                 (return nm)
 344                 (addTickLHsExpr e)
 345 addTickHsExpr (HsCoreAnn nm e) =
 346         liftM2 HsCoreAnn
 347                 (return nm)
 348                 (addTickLHsExpr e)
 349 addTickHsExpr e@(HsBracket     {}) = return e
 350 addTickHsExpr e@(HsBracketOut  {}) = return e
 351 addTickHsExpr e@(HsSpliceE  {}) = return e
 352 addTickHsExpr (HsProc pat cmdtop) =
 353         liftM2 HsProc
 354                 (addTickLPat pat)
 355                 (liftL (addTickHsCmdTop) cmdtop)
 356 addTickHsExpr (HsWrap w e) =
 357         liftM2 HsWrap
 358                 (return w)
 359                 (addTickHsExpr e)       -- explicitly no tick on inside
 360 addTickHsExpr (HsArrApp  e1 e2 ty1 arr_ty lr) =
 361         liftM5 HsArrApp
 362                (addTickLHsExpr e1)
 363                (addTickLHsExpr e2)
 364                (return ty1)
 365                (return arr_ty)
 366                (return lr)
 367 addTickHsExpr (HsArrForm e fix cmdtop) =
 368         liftM3 HsArrForm
 369                (addTickLHsExpr e)
 370                (return fix)
 371                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 372
 373 addTickHsExpr e@(HsType _) = return e
 374
 375 -- Others dhould never happen in expression content.
 376 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
 377
 378 addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
 379 addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
 380 addTickTupArg (Missing ty) = return (Missing ty)
 381
 382 addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
 383 addTickMatchGroup (MatchGroup matches ty) = do
 384   let isOneOfMany = matchesOneOfMany matches
 385   matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
 386   return $ MatchGroup matches' ty
 387
 388 addTickMatch :: Bool -> Match Id -> TM (Match Id)
 389 addTickMatch isOneOfMany (Match pats opSig gRHSs) =
 390   bindLocals (collectPatsBinders pats) $ do
 391     gRHSs' <- addTickGRHSs isOneOfMany gRHSs
 392     return $ Match pats opSig gRHSs'
 393
 394 addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
 395 addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
 396   bindLocals binders $ do
 397     local_binds' <- addTickHsLocalBinds local_binds
 398     guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
 399     return $ GRHSs guarded' local_binds'
 400   where
 401     binders = map unLoc (collectLocalBinders local_binds)
 402
 403 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
 404 addTickGRHS isOneOfMany (GRHS stmts expr) = do
 405   (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
 406                         (if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
 407                                     else addTickLHsExprAlways expr)
 408   return $ GRHS stmts' expr'
 409
 410 addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
 411 addTickLStmts isGuard stmts = do
 412   (stmts, _) <- addTickLStmts' isGuard stmts (return ())
 413   return stmts
 414
 415 addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
 416                -> TM ([LStmt Id], a)
 417 addTickLStmts' isGuard lstmts res
 418   = bindLocals binders $ do
 419         lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
 420         a <- res
 421         return (lstmts', a)
 422   where
 423         binders = map unLoc (collectLStmtsBinders lstmts)
 424
 425 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
 426 addTickStmt _isGuard (BindStmt pat e bind fail) = do
 427         liftM4 BindStmt
 428                 (addTickLPat pat)
 429                 (addTickLHsExprAlways e)
 430                 (addTickSyntaxExpr hpcSrcSpan bind)
 431                 (addTickSyntaxExpr hpcSrcSpan fail)
 432 addTickStmt isGuard (ExprStmt e bind' ty) = do
 433         liftM3 ExprStmt
 434                 (addTick isGuard e)
 435                 (addTickSyntaxExpr hpcSrcSpan bind')
 436                 (return ty)
 437 addTickStmt _isGuard (LetStmt binds) = do
 438         liftM LetStmt
 439                 (addTickHsLocalBinds binds)
 440 addTickStmt isGuard (ParStmt pairs) = do
 441     liftM ParStmt
 442         (mapM (addTickStmtAndBinders isGuard) pairs)
 443 addTickStmt isGuard (TransformStmt (stmts, ids) usingExpr maybeByExpr) = do
 444     liftM3 TransformStmt
 445         (addTickStmtAndBinders isGuard (stmts, ids))
 446         (addTickLHsExprAlways usingExpr)
 447         (addTickMaybeByLHsExpr maybeByExpr)
 448 addTickStmt isGuard (GroupStmt (stmts, binderMap) groupByClause) = do
 449     liftM2 GroupStmt
 450         (addTickStmtAndBinders isGuard (stmts, binderMap))
 451         (case groupByClause of
 452             GroupByNothing usingExpr -> addTickLHsExprAlways usingExpr >>= (return . GroupByNothing)
 453             GroupBySomething eitherUsingExpr byExpr -> do
 454                 eitherUsingExpr' <- mapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) eitherUsingExpr
 455                 byExpr' <- addTickLHsExprAlways byExpr
 456                 return $ GroupBySomething eitherUsingExpr' byExpr')
 457     where
 458         mapEitherM f g x = do
 459           case x of
 460             Left a -> f a >>= (return . Left)
 461             Right b -> g b >>= (return . Right)
 462 addTickStmt isGuard stmt@(RecStmt {})
 463   = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
 464        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
 465        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
 466        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
 467        ; dicts' <- addTickDictBinds (recS_dicts stmt)
 468        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
 469                       , recS_mfix_fn = mfix', recS_bind_fn = bind'
 470                       , recS_dicts = dicts' }) }
 471
 472 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 473 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
 474                   | otherwise          = addTickLHsExprAlways e
 475
 476 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a)
 477                       -> TM ([LStmt Id], a)
 478 addTickStmtAndBinders isGuard (stmts, ids) =
 479     liftM2 (,)
 480         (addTickLStmts isGuard stmts)
 481         (return ids)
 482
 483 addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
 484 addTickMaybeByLHsExpr maybeByExpr =
 485     case maybeByExpr of
 486         Nothing -> return Nothing
 487         Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
 488
 489 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 490 addTickHsLocalBinds (HsValBinds binds) =
 491         liftM HsValBinds
 492                 (addTickHsValBinds binds)
 493 addTickHsLocalBinds (HsIPBinds binds)  =
 494         liftM HsIPBinds
 495                 (addTickHsIPBinds binds)
 496 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
 497
 498 addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
 499 addTickHsValBinds (ValBindsOut binds sigs) =
 500         liftM2 ValBindsOut
 501                 (mapM (\ (rec,binds') ->
 502                                 liftM2 (,)
 503                                         (return rec)
 504                                         (addTickLHsBinds binds'))
 505                         binds)
 506                 (return sigs)
 507 addTickHsValBinds _ = panic "addTickHsValBinds"
 508
 509 addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
 510 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
 511         liftM2 IPBinds
 512                 (mapM (liftL (addTickIPBind)) ipbinds)
 513                 (addTickDictBinds dictbinds)
 514
 515 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 516 addTickIPBind (IPBind nm e) =
 517         liftM2 IPBind
 518                 (return nm)
 519                 (addTickLHsExpr e)
 520
 521 -- There is no location here, so we might need to use a context location??
 522 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
 523 addTickSyntaxExpr pos x = do
 524         L _ x' <- addTickLHsExpr (L pos x)
 525         return $ x'
 526 -- we do not walk into patterns.
 527 addTickLPat :: LPat Id -> TM (LPat Id)
 528 addTickLPat pat = return pat
 529
 530 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
 531 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 532         liftM4 HsCmdTop
 533                 (addTickLHsCmd cmd)
 534                 (return tys)
 535                 (return ty)
 536                 (return syntaxtable)
 537
 538 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 539 addTickLHsCmd x = addTickLHsExpr x
 540
 541 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
 542 addTickDictBinds x = addTickLHsBinds x
 543
 544 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 545 addTickHsRecordBinds (HsRecFields fields dd)
 546   = do  { fields' <- mapM process fields
 547         ; return (HsRecFields fields' dd) }
 548   where
 549     process (HsRecField ids expr doc)
 550         = do { expr' <- addTickLHsExpr expr
 551              ; return (HsRecField ids expr' doc) }
 552
 553 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
 554 addTickArithSeqInfo (From e1) =
 555         liftM From
 556                 (addTickLHsExpr e1)
 557 addTickArithSeqInfo (FromThen e1 e2) =
 558         liftM2 FromThen
 559                 (addTickLHsExpr e1)
 560                 (addTickLHsExpr e2)
 561 addTickArithSeqInfo (FromTo e1 e2) =
 562         liftM2 FromTo
 563                 (addTickLHsExpr e1)
 564                 (addTickLHsExpr e2)
 565 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
 566         liftM3 FromThenTo
 567                 (addTickLHsExpr e1)
 568                 (addTickLHsExpr e2)
 569                 (addTickLHsExpr e3)
 570 \end{code}
 571
 572 \begin{code}
 573 data TickTransState = TT { tickBoxCount:: Int
 574                          , mixEntries  :: [MixEntry_]
 575                          }
 576
 577 data TickTransEnv = TTE { fileName      :: FastString
 578                         , declPath     :: [String]
 579                         , inScope      :: VarSet
 580                         , blackList   :: FiniteMap SrcSpan ()
 581                         }
 582
 583 --      deriving Show
 584
 585 type FreeVars = OccEnv Id
 586 noFVs :: FreeVars
 587 noFVs = emptyOccEnv
 588
 589 -- Note [freevars]
 590 --   For breakpoints we want to collect the free variables of an
 591 --   expression for pinning on the HsTick.  We don't want to collect
 592 --   *all* free variables though: in particular there's no point pinning
 593 --   on free variables that are will otherwise be in scope at the GHCi
 594 --   prompt, which means all top-level bindings.  Unfortunately detecting
 595 --   top-level bindings isn't easy (collectHsBindsBinders on the top-level
 596 --   bindings doesn't do it), so we keep track of a set of "in-scope"
 597 --   variables in addition to the free variables, and the former is used
 598 --   to filter additions to the latter.  This gives us complete control
 599 --   over what free variables we track.
 600
 601 data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
 602         -- a combination of a state monad (TickTransState) and a writer
 603         -- monad (FreeVars).
 604
 605 instance Monad TM where
 606   return a = TM $ \ _env st -> (a,noFVs,st)
 607   (TM m) >>= k = TM $ \ env st ->
 608                                 case m env st of
 609                                   (r1,fv1,st1) ->
 610                                      case unTM (k r1) env st1 of
 611                                        (r2,fv2,st2) ->
 612                                           (r2, fv1 `plusOccEnv` fv2, st2)
 613
 614 -- getState :: TM TickTransState
 615 -- getState = TM $ \ env st -> (st, noFVs, st)
 616
 617 -- setState :: (TickTransState -> TickTransState) -> TM ()
 618 -- setState f = TM $ \ env st -> ((), noFVs, f st)
 619
 620 getEnv :: TM TickTransEnv
 621 getEnv = TM $ \ env st -> (env, noFVs, st)
 622
 623 withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
 624 withEnv f (TM m) = TM $ \ env st ->
 625                                  case m (f env) st of
 626                                    (a, fvs, st') -> (a, fvs, st')
 627
 628 getFreeVars :: TM a -> TM (FreeVars, a)
 629 getFreeVars (TM m)
 630   = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
 631
 632 freeVar :: Id -> TM ()
 633 freeVar id = TM $ \ env st ->
 634                 if id `elemVarSet` inScope env
 635                    then ((), unitOccEnv (nameOccName (idName id)) id, st)
 636                    else ((), noFVs, st)
 637
 638 addPathEntry :: String -> TM a -> TM a
 639 addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
 640
 641 getPathEntry :: TM [String]
 642 getPathEntry = declPath `liftM` getEnv
 643
 644 getFileName :: TM FastString
 645 getFileName = fileName `liftM` getEnv
 646
 647 sameFileName :: SrcSpan -> TM a -> TM a -> TM a
 648 sameFileName pos out_of_scope in_scope = do
 649   file_name <- getFileName
 650   case srcSpanFileName_maybe pos of
 651     Just file_name2
 652       | file_name == file_name2 -> in_scope
 653     _ -> out_of_scope
 654
 655 bindLocals :: [Id] -> TM a -> TM a
 656 bindLocals new_ids (TM m)
 657   = TM $ \ env st ->
 658                  case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
 659                    (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
 660   where occs = [ nameOccName (idName id) | id <- new_ids ]
 661
 662 isBlackListed :: SrcSpan -> TM Bool
 663 isBlackListed pos = TM $ \ env st ->
 664               case lookupFM (blackList env) pos of
 665                 Nothing -> (False,noFVs,st)
 666                 Just () -> (True,noFVs,st)
 667
 668 -- the tick application inherits the source position of its
 669 -- expression argument to support nested box allocations
 670 allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
 671 allocTickBox boxLabel pos m | isGoodSrcSpan' pos =
 672   sameFileName pos
 673     (do e <- m; return (L pos e)) $ do
 674   (fvs, e) <- getFreeVars m
 675   TM $ \ _env st ->
 676     let c = tickBoxCount st
 677         ids = occEnvElts fvs
 678         mes = mixEntries st
 679         me = (pos, map (nameOccName.idName) ids, boxLabel)
 680     in
 681     ( L pos (HsTick c ids (L pos e))
 682     , fvs
 683     , st {tickBoxCount=c+1,mixEntries=me:mes}
 684     )
 685 allocTickBox _boxLabel pos m = do e <- m; return (L pos e)
 686
 687 -- the tick application inherits the source position of its
 688 -- expression argument to support nested box allocations
 689 allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
 690 allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos =
 691   sameFileName pos
 692     (return Nothing) $ TM $ \ _env st ->
 693   let me = (pos, map (nameOccName.idName) ids, boxLabel)
 694       c = tickBoxCount st
 695       mes = mixEntries st
 696       ids = occEnvElts fvs
 697   in ( Just (c, ids)
 698      , noFVs
 699      , st {tickBoxCount=c+1, mixEntries=me:mes}
 700      )
 701 allocATickBox _boxLabel _pos _fvs = return Nothing
 702
 703 allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
 704                 -> TM (LHsExpr Id)
 705 allocBinTickBox boxLabel pos m
 706  | not opt_Hpc = allocTickBox (ExpBox False) pos m
 707  | isGoodSrcSpan' pos =
 708  do
 709  e <- m
 710  TM $ \ _env st ->
 711   let meT = (pos,[],boxLabel True)
 712       meF = (pos,[],boxLabel False)
 713       meE = (pos,[],ExpBox False)
 714       c = tickBoxCount st
 715       mes = mixEntries st
 716   in
 717              ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
 718            -- notice that F and T are reversed,
 719            -- because we are building the list in
 720            -- reverse...
 721              , noFVs
 722              , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
 723              )
 724 allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
 725
 726 isGoodSrcSpan' :: SrcSpan -> Bool
 727 isGoodSrcSpan' pos
 728    | not (isGoodSrcSpan pos) = False
 729    | start == end            = False
 730    | otherwise               = True
 731   where
 732    start = srcSpanStart pos
 733    end   = srcSpanEnd pos
 734
 735 mkHpcPos :: SrcSpan -> HpcPos
 736 mkHpcPos pos
 737    | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
 738    | otherwise                = hpcPos
 739   where
 740    start = srcSpanStart pos
 741    end   = srcSpanEnd pos
 742    hpcPos = toHpcPos ( srcLocLine start
 743                      , srcLocCol start
 744                      , srcLocLine end
 745                      , srcLocCol end - 1
 746                      )
 747
 748 hpcSrcSpan :: SrcSpan
 749 hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
 750 \end{code}
 751
 752
 753 \begin{code}
 754 matchesOneOfMany :: [LMatch Id] -> Bool
 755 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
 756   where
 757         matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
 758 \end{code}
 759
 760
 761 \begin{code}
 762 type MixEntry_ = (SrcSpan, [OccName], BoxLabel)
 763
 764 -- For the hash value, we hash everything: the file name,
 765 --  the timestamp of the original source file, the tab stop,
 766 --  and the mix entries. We cheat, and hash the show'd string.
 767 -- This hash only has to be hashed at Mix creation time,
 768 -- and is for sanity checking only.
 769
 770 mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
 771 mixHash file tm tabstop entries = fromIntegral $ hashString
 772         (show $ Mix file tm 0 tabstop entries)
 773 \end{code}