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