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