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