compiler/deSugar/Coverage.lhs

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