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, emptyHpcInfo False, emptyModBreaks) else do
  73
  74   let mod_name = moduleNameString (moduleName mod)
  75
  76   let (binds1,_,st)
  77                  = unTM (addTickLHsBinds binds)
  78                    (TTE
  79                        { fileName    = mkFastString orig_file
  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 ty es) =
 314         liftM2 ExplicitPArr
 315                 (return ty)
 316                 (mapM (addTickLHsExpr) es)
 317 addTickHsExpr (ExplicitTuple es box) =
 318         liftM2 ExplicitTuple
 319                 (mapM (addTickLHsExpr) es)
 320                 (return box)
 321 addTickHsExpr (RecordCon id ty rec_binds) =
 322         liftM3 RecordCon
 323                 (return id)
 324                 (return ty)
 325                 (addTickHsRecordBinds rec_binds)
 326 addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
 327         liftM5 RecordUpd
 328                 (addTickLHsExpr e)
 329                 (addTickHsRecordBinds rec_binds)
 330                 (return cons) (return tys1) (return tys2)
 331
 332 addTickHsExpr (ExprWithTySigOut e ty) =
 333         liftM2 ExprWithTySigOut
 334                 (addTickLHsExprNever e) -- No need to tick the inner expression
 335                                     -- for expressions with signatures
 336                 (return ty)
 337 addTickHsExpr (ArithSeq  ty arith_seq) =
 338         liftM2 ArithSeq
 339                 (return ty)
 340                 (addTickArithSeqInfo arith_seq)
 341 addTickHsExpr (HsTickPragma (file,(l1,c1),(l2,c2)) (L pos e0)) = do
 342     e2 <- allocTickBox (ExpBox False) pos $
 343                 addTickHsExpr e0
 344     return $ unLoc e2
 345 addTickHsExpr (PArrSeq   ty arith_seq) =
 346         liftM2 PArrSeq
 347                 (return ty)
 348                 (addTickArithSeqInfo arith_seq)
 349 addTickHsExpr (HsSCC nm e) =
 350         liftM2 HsSCC
 351                 (return nm)
 352                 (addTickLHsExpr e)
 353 addTickHsExpr (HsCoreAnn nm e) =
 354         liftM2 HsCoreAnn
 355                 (return nm)
 356                 (addTickLHsExpr e)
 357 addTickHsExpr e@(HsBracket     {}) = return e
 358 addTickHsExpr e@(HsBracketOut  {}) = return e
 359 addTickHsExpr e@(HsSpliceE  {}) = return e
 360 addTickHsExpr (HsProc pat cmdtop) =
 361         liftM2 HsProc
 362                 (addTickLPat pat)
 363                 (liftL (addTickHsCmdTop) cmdtop)
 364 addTickHsExpr (HsWrap w e) =
 365         liftM2 HsWrap
 366                 (return w)
 367                 (addTickHsExpr e)       -- explicitly no tick on inside
 368 addTickHsExpr (HsArrApp  e1 e2 ty1 arr_ty lr) =
 369         liftM5 HsArrApp
 370                (addTickLHsExpr e1)
 371                (addTickLHsExpr e2)
 372                (return ty1)
 373                (return arr_ty)
 374                (return lr)
 375 addTickHsExpr (HsArrForm e fix cmdtop) =
 376         liftM3 HsArrForm
 377                (addTickLHsExpr e)
 378                (return fix)
 379                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 380
 381 addTickHsExpr e@(HsType ty) = return e
 382
 383 -- Others dhould never happen in expression content.
 384 addTickHsExpr e@(ExprWithTySig {}) = pprPanic "addTickHsExpr" (ppr e)
 385 addTickHsExpr e@(EAsPat _ _)       = pprPanic "addTickHsExpr" (ppr e)
 386 addTickHsExpr e@(ELazyPat _)       = pprPanic "addTickHsExpr" (ppr e)
 387 addTickHsExpr e@(EWildPat)         = pprPanic "addTickHsExpr" (ppr e)
 388 addTickHsExpr e@(HsBinTick _ _ _)  = pprPanic "addTickHsExpr" (ppr e)
 389 addTickHsExpr e@(HsTick _ _ _)     = pprPanic "addTickHsExpr" (ppr e)
 390
 391 addTickMatchGroup (MatchGroup matches ty) = do
 392   let isOneOfMany = matchesOneOfMany matches
 393   matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
 394   return $ MatchGroup matches' ty
 395
 396 addTickMatch :: Bool -> Match Id -> TM (Match Id)
 397 addTickMatch isOneOfMany (Match pats opSig gRHSs) =
 398   bindLocals (collectPatsBinders pats) $ do
 399     gRHSs' <- addTickGRHSs isOneOfMany gRHSs
 400     return $ Match pats opSig gRHSs'
 401
 402 addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
 403 addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
 404   bindLocals binders $ do
 405     local_binds' <- addTickHsLocalBinds local_binds
 406     guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
 407     return $ GRHSs guarded' local_binds'
 408   where
 409     binders = map unLoc (collectLocalBinders local_binds)
 410
 411 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
 412 addTickGRHS isOneOfMany (GRHS stmts expr) = do
 413   (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
 414                         (if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
 415                                     else addTickLHsExprAlways expr)
 416   return $ GRHS stmts' expr'
 417
 418 addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
 419 addTickLStmts isGuard stmts = do
 420   (stmts, _) <- addTickLStmts' isGuard stmts (return ())
 421   return stmts
 422
 423 addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
 424                -> TM ([LStmt Id], a)
 425 addTickLStmts' isGuard lstmts res
 426   = bindLocals binders $ do
 427         lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
 428         a <- res
 429         return (lstmts', a)
 430   where
 431         binders = map unLoc (collectLStmtsBinders lstmts)
 432
 433 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
 434 addTickStmt isGuard (BindStmt pat e bind fail) = do
 435         liftM4 BindStmt
 436                 (addTickLPat pat)
 437                 (addTickLHsExprAlways e)
 438                 (addTickSyntaxExpr hpcSrcSpan bind)
 439                 (addTickSyntaxExpr hpcSrcSpan fail)
 440 addTickStmt isGuard (ExprStmt e bind' ty) = do
 441         liftM3 ExprStmt
 442                 (addTick e)
 443                 (addTickSyntaxExpr hpcSrcSpan bind')
 444                 (return ty)
 445   where
 446    addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
 447              | otherwise          = addTickLHsExprAlways e
 448
 449 addTickStmt isGuard (LetStmt binds) = do
 450         liftM LetStmt
 451                 (addTickHsLocalBinds binds)
 452 addTickStmt isGuard (ParStmt pairs) = do
 453         liftM ParStmt (mapM process pairs)
 454   where
 455         process (stmts,ids) =
 456                 liftM2 (,)
 457                         (addTickLStmts isGuard stmts)
 458                         (return ids)
 459 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
 460         liftM5 RecStmt
 461                 (addTickLStmts isGuard stmts)
 462                 (return ids1)
 463                 (return ids2)
 464                 (return tys)
 465                 (addTickDictBinds dictbinds)
 466
 467 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 468 addTickHsLocalBinds (HsValBinds binds) =
 469         liftM HsValBinds
 470                 (addTickHsValBinds binds)
 471 addTickHsLocalBinds (HsIPBinds binds)  =
 472         liftM HsIPBinds
 473                 (addTickHsIPBinds binds)
 474 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
 475
 476 addTickHsValBinds (ValBindsOut binds sigs) =
 477         liftM2 ValBindsOut
 478                 (mapM (\ (rec,binds') ->
 479                                 liftM2 (,)
 480                                         (return rec)
 481                                         (addTickLHsBinds binds'))
 482                         binds)
 483                 (return sigs)
 484
 485 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
 486         liftM2 IPBinds
 487                 (mapM (liftL (addTickIPBind)) ipbinds)
 488                 (addTickDictBinds dictbinds)
 489
 490 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 491 addTickIPBind (IPBind nm e) =
 492         liftM2 IPBind
 493                 (return nm)
 494                 (addTickLHsExpr e)
 495
 496 -- There is no location here, so we might need to use a context location??
 497 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
 498 addTickSyntaxExpr pos x = do
 499         L _ x' <- addTickLHsExpr (L pos x)
 500         return $ x'
 501 -- we do not walk into patterns.
 502 addTickLPat :: LPat Id -> TM (LPat Id)
 503 addTickLPat pat = return pat
 504
 505 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
 506 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 507         liftM4 HsCmdTop
 508                 (addTickLHsCmd cmd)
 509                 (return tys)
 510                 (return ty)
 511                 (return syntaxtable)
 512
 513 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 514 addTickLHsCmd x = addTickLHsExpr x
 515
 516 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
 517 addTickDictBinds x = addTickLHsBinds x
 518
 519 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 520 addTickHsRecordBinds (HsRecFields fields dd)
 521   = do  { fields' <- mapM process fields
 522         ; return (HsRecFields fields' dd) }
 523   where
 524     process (HsRecField ids expr doc)
 525         = do { expr' <- addTickLHsExpr expr
 526              ; return (HsRecField ids expr' doc) }
 527
 528 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
 529 addTickArithSeqInfo (From e1) =
 530         liftM From
 531                 (addTickLHsExpr e1)
 532 addTickArithSeqInfo (FromThen e1 e2) =
 533         liftM2 FromThen
 534                 (addTickLHsExpr e1)
 535                 (addTickLHsExpr e2)
 536 addTickArithSeqInfo (FromTo e1 e2) =
 537         liftM2 FromTo
 538                 (addTickLHsExpr e1)
 539                 (addTickLHsExpr e2)
 540 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
 541         liftM3 FromThenTo
 542                 (addTickLHsExpr e1)
 543                 (addTickLHsExpr e2)
 544                 (addTickLHsExpr e3)
 545 \end{code}
 546
 547 \begin{code}
 548 data TickTransState = TT { tickBoxCount:: Int
 549                          , mixEntries  :: [MixEntry_]
 550                          }
 551
 552 data TickTransEnv = TTE { fileName      :: FastString
 553                         , declPath     :: [String]
 554                         , inScope      :: VarSet
 555                         , blackList   :: FiniteMap SrcSpan ()
 556                         }
 557
 558 --      deriving Show
 559
 560 type FreeVars = OccEnv Id
 561 noFVs = emptyOccEnv
 562
 563 -- Note [freevars]
 564 --   For breakpoints we want to collect the free variables of an
 565 --   expression for pinning on the HsTick.  We don't want to collect
 566 --   *all* free variables though: in particular there's no point pinning
 567 --   on free variables that are will otherwise be in scope at the GHCi
 568 --   prompt, which means all top-level bindings.  Unfortunately detecting
 569 --   top-level bindings isn't easy (collectHsBindsBinders on the top-level
 570 --   bindings doesn't do it), so we keep track of a set of "in-scope"
 571 --   variables in addition to the free variables, and the former is used
 572 --   to filter additions to the latter.  This gives us complete control
 573 --   over what free variables we track.
 574
 575 data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
 576         -- a combination of a state monad (TickTransState) and a writer
 577         -- monad (FreeVars).
 578
 579 instance Monad TM where
 580   return a = TM $ \ env st -> (a,noFVs,st)
 581   (TM m) >>= k = TM $ \ env st ->
 582                                 case m env st of
 583                                   (r1,fv1,st1) ->
 584                                      case unTM (k r1) env st1 of
 585                                        (r2,fv2,st2) ->
 586                                           (r2, fv1 `plusOccEnv` fv2, st2)
 587
 588 -- getState :: TM TickTransState
 589 -- getState = TM $ \ env st -> (st, noFVs, st)
 590
 591 setState :: (TickTransState -> TickTransState) -> TM ()
 592 setState f = TM $ \ env st -> ((), noFVs, f st)
 593
 594 getEnv :: TM TickTransEnv
 595 getEnv = TM $ \ env st -> (env, noFVs, st)
 596
 597 withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
 598 withEnv f (TM m) = TM $ \ env st ->
 599                                  case m (f env) st of
 600                                    (a, fvs, st') -> (a, fvs, st')
 601
 602 getFreeVars :: TM a -> TM (FreeVars, a)
 603 getFreeVars (TM m)
 604   = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
 605
 606 freeVar :: Id -> TM ()
 607 freeVar id = TM $ \ env st ->
 608                 if id `elemVarSet` inScope env
 609                    then ((), unitOccEnv (nameOccName (idName id)) id, st)
 610                    else ((), noFVs, st)
 611
 612 addPathEntry :: String -> TM a -> TM a
 613 addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
 614
 615 getPathEntry :: TM [String]
 616 getPathEntry = declPath `liftM` getEnv
 617
 618 getFileName :: TM FastString
 619 getFileName = fileName `liftM` getEnv
 620
 621 sameFileName :: SrcSpan -> TM a -> TM a -> TM a
 622 sameFileName pos out_of_scope in_scope = do
 623   file_name <- getFileName
 624   case optSrcSpanFileName pos of
 625     Just file_name2
 626       | file_name == file_name2 -> in_scope
 627     _ -> out_of_scope
 628
 629 bindLocals :: [Id] -> TM a -> TM a
 630 bindLocals new_ids (TM m)
 631   = TM $ \ env st ->
 632                  case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
 633                    (r, fv, st') -> (r, fv `delListFromUFM` occs, st')
 634   where occs = [ nameOccName (idName id) | id <- new_ids ]
 635
 636 isBlackListed :: SrcSpan -> TM Bool
 637 isBlackListed pos = TM $ \ env st ->
 638               case lookupFM (blackList env) pos of
 639                 Nothing -> (False,noFVs,st)
 640                 Just () -> (True,noFVs,st)
 641
 642 -- the tick application inherits the source position of its
 643 -- expression argument to support nested box allocations
 644 allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
 645 allocTickBox boxLabel pos m | isGoodSrcSpan' pos =
 646   sameFileName pos
 647     (do e <- m; return (L pos e)) $ do
 648   (fvs, e) <- getFreeVars m
 649   TM $ \ env st ->
 650     let c = tickBoxCount st
 651         ids = occEnvElts fvs
 652         mes = mixEntries st
 653         me = (pos, map (nameOccName.idName) ids, boxLabel)
 654     in
 655     ( L pos (HsTick c ids (L pos e))
 656     , fvs
 657     , st {tickBoxCount=c+1,mixEntries=me:mes}
 658     )
 659 allocTickBox boxLabel pos m = do e <- m; return (L pos e)
 660
 661 -- the tick application inherits the source position of its
 662 -- expression argument to support nested box allocations
 663 allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
 664 allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos =
 665   sameFileName pos
 666     (return Nothing) $ TM $ \ env st ->
 667   let me = (pos, map (nameOccName.idName) ids, boxLabel)
 668       c = tickBoxCount st
 669       mes = mixEntries st
 670       ids = occEnvElts fvs
 671   in ( Just (c, ids)
 672      , noFVs
 673      , st {tickBoxCount=c+1, mixEntries=me:mes}
 674      )
 675 allocATickBox boxLabel pos fvs = return Nothing
 676
 677 allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 678 allocBinTickBox boxLabel (L pos e) | isGoodSrcSpan' pos = TM $ \ env st ->
 679   let meT = (pos,[],boxLabel True)
 680       meF = (pos,[],boxLabel False)
 681       meE = (pos,[],ExpBox False)
 682       c = tickBoxCount st
 683       mes = mixEntries st
 684   in
 685      if opt_Hpc
 686         then ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
 687            -- notice that F and T are reversed,
 688            -- because we are building the list in
 689            -- reverse...
 690              , noFVs
 691              , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
 692              )
 693         else
 694              ( L pos $ HsTick c [] $ L pos e
 695              , noFVs
 696              , st {tickBoxCount=c+1,mixEntries=meE:mes}
 697              )
 698
 699 allocBinTickBox boxLabel e = return e
 700
 701 isGoodSrcSpan' pos
 702    | not (isGoodSrcSpan pos) = False
 703    | start == end            = False
 704    | otherwise               = True
 705   where
 706    start = srcSpanStart pos
 707    end   = srcSpanEnd pos
 708
 709 mkHpcPos :: SrcSpan -> HpcPos
 710 mkHpcPos pos
 711    | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
 712    | otherwise                = hpcPos
 713   where
 714    start = srcSpanStart pos
 715    end   = srcSpanEnd pos
 716    hpcPos = toHpcPos ( srcLocLine start
 717                      , srcLocCol start + 1
 718                      , srcLocLine end
 719                      , srcLocCol end
 720                      )
 721
 722 noHpcPos = toHpcPos (0,0,0,0)
 723
 724 hpcSrcSpan = mkGeneralSrcSpan (FSLIT("Haskell Program Coverage internals"))
 725 \end{code}
 726
 727
 728 \begin{code}
 729 matchesOneOfMany :: [LMatch Id] -> Bool
 730 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
 731   where
 732         matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
 733 \end{code}
 734
 735
 736 \begin{code}
 737 type MixEntry_ = (SrcSpan, [OccName], BoxLabel)
 738
 739 -- For the hash value, we hash everything: the file name,
 740 --  the timestamp of the original source file, the tab stop,
 741 --  and the mix entries. We cheat, and hash the show'd string.
 742 -- This hash only has to be hashed at Mix creation time,
 743 -- and is for sanity checking only.
 744
 745 mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
 746 mixHash file tm tabstop entries = fromIntegral $ hashString
 747         (show $ Mix file tm 0 tabstop entries)
 748 \end{code}