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