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