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