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