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 e)
 446                 (addTickSyntaxExpr hpcSrcSpan bind')
 447                 (return ty)
 448   where
 449    addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
 450              | otherwise          = addTickLHsExprAlways e
 451
 452 addTickStmt isGuard (LetStmt binds) = do
 453         liftM LetStmt
 454                 (addTickHsLocalBinds binds)
 455 addTickStmt isGuard (ParStmt pairs) = do
 456         liftM ParStmt (mapM process pairs)
 457   where
 458         process (stmts,ids) =
 459                 liftM2 (,)
 460                         (addTickLStmts isGuard stmts)
 461                         (return ids)
 462 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
 463         liftM5 RecStmt
 464                 (addTickLStmts isGuard stmts)
 465                 (return ids1)
 466                 (return ids2)
 467                 (return tys)
 468                 (addTickDictBinds dictbinds)
 469
 470 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 471 addTickHsLocalBinds (HsValBinds binds) =
 472         liftM HsValBinds
 473                 (addTickHsValBinds binds)
 474 addTickHsLocalBinds (HsIPBinds binds)  =
 475         liftM HsIPBinds
 476                 (addTickHsIPBinds binds)
 477 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
 478
 479 addTickHsValBinds (ValBindsOut binds sigs) =
 480         liftM2 ValBindsOut
 481                 (mapM (\ (rec,binds') ->
 482                                 liftM2 (,)
 483                                         (return rec)
 484                                         (addTickLHsBinds binds'))
 485                         binds)
 486                 (return sigs)
 487
 488 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
 489         liftM2 IPBinds
 490                 (mapM (liftL (addTickIPBind)) ipbinds)
 491                 (addTickDictBinds dictbinds)
 492
 493 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 494 addTickIPBind (IPBind nm e) =
 495         liftM2 IPBind
 496                 (return nm)
 497                 (addTickLHsExpr e)
 498
 499 -- There is no location here, so we might need to use a context location??
 500 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
 501 addTickSyntaxExpr pos x = do
 502         L _ x' <- addTickLHsExpr (L pos x)
 503         return $ x'
 504 -- we do not walk into patterns.
 505 addTickLPat :: LPat Id -> TM (LPat Id)
 506 addTickLPat pat = return pat
 507
 508 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
 509 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 510         liftM4 HsCmdTop
 511                 (addTickLHsCmd cmd)
 512                 (return tys)
 513                 (return ty)
 514                 (return syntaxtable)
 515
 516 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 517 addTickLHsCmd x = addTickLHsExpr x
 518
 519 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
 520 addTickDictBinds x = addTickLHsBinds x
 521
 522 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 523 addTickHsRecordBinds (HsRecFields fields dd)
 524   = do  { fields' <- mapM process fields
 525         ; return (HsRecFields fields' dd) }
 526   where
 527     process (HsRecField ids expr doc)
 528         = do { expr' <- addTickLHsExpr expr
 529              ; return (HsRecField ids expr' doc) }
 530
 531 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
 532 addTickArithSeqInfo (From e1) =
 533         liftM From
 534                 (addTickLHsExpr e1)
 535 addTickArithSeqInfo (FromThen e1 e2) =
 536         liftM2 FromThen
 537                 (addTickLHsExpr e1)
 538                 (addTickLHsExpr e2)
 539 addTickArithSeqInfo (FromTo e1 e2) =
 540         liftM2 FromTo
 541                 (addTickLHsExpr e1)
 542                 (addTickLHsExpr e2)
 543 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
 544         liftM3 FromThenTo
 545                 (addTickLHsExpr e1)
 546                 (addTickLHsExpr e2)
 547                 (addTickLHsExpr e3)
 548 \end{code}
 549
 550 \begin{code}
 551 data TickTransState = TT { tickBoxCount:: Int
 552                          , mixEntries  :: [MixEntry_]
 553                          }
 554
 555 data TickTransEnv = TTE { fileName      :: FastString
 556                         , declPath     :: [String]
 557                         , inScope      :: VarSet
 558                         , blackList   :: FiniteMap SrcSpan ()
 559                         }
 560
 561 --      deriving Show
 562
 563 type FreeVars = OccEnv Id
 564 noFVs = emptyOccEnv
 565
 566 -- Note [freevars]
 567 --   For breakpoints we want to collect the free variables of an
 568 --   expression for pinning on the HsTick.  We don't want to collect
 569 --   *all* free variables though: in particular there's no point pinning
 570 --   on free variables that are will otherwise be in scope at the GHCi
 571 --   prompt, which means all top-level bindings.  Unfortunately detecting
 572 --   top-level bindings isn't easy (collectHsBindsBinders on the top-level
 573 --   bindings doesn't do it), so we keep track of a set of "in-scope"
 574 --   variables in addition to the free variables, and the former is used
 575 --   to filter additions to the latter.  This gives us complete control
 576 --   over what free variables we track.
 577
 578 data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
 579         -- a combination of a state monad (TickTransState) and a writer
 580         -- monad (FreeVars).
 581
 582 instance Monad TM where
 583   return a = TM $ \ env st -> (a,noFVs,st)
 584   (TM m) >>= k = TM $ \ env st ->
 585                                 case m env st of
 586                                   (r1,fv1,st1) ->
 587                                      case unTM (k r1) env st1 of
 588                                        (r2,fv2,st2) ->
 589                                           (r2, fv1 `plusOccEnv` fv2, st2)
 590
 591 -- getState :: TM TickTransState
 592 -- getState = TM $ \ env st -> (st, noFVs, st)
 593
 594 setState :: (TickTransState -> TickTransState) -> TM ()
 595 setState f = TM $ \ env st -> ((), noFVs, f st)
 596
 597 getEnv :: TM TickTransEnv
 598 getEnv = TM $ \ env st -> (env, noFVs, st)
 599
 600 withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
 601 withEnv f (TM m) = TM $ \ env st ->
 602                                  case m (f env) st of
 603                                    (a, fvs, st') -> (a, fvs, st')
 604
 605 getFreeVars :: TM a -> TM (FreeVars, a)
 606 getFreeVars (TM m)
 607   = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
 608
 609 freeVar :: Id -> TM ()
 610 freeVar id = TM $ \ env st ->
 611                 if id `elemVarSet` inScope env
 612                    then ((), unitOccEnv (nameOccName (idName id)) id, st)
 613                    else ((), noFVs, st)
 614
 615 addPathEntry :: String -> TM a -> TM a
 616 addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
 617
 618 getPathEntry :: TM [String]
 619 getPathEntry = declPath `liftM` getEnv
 620
 621 getFileName :: TM FastString
 622 getFileName = fileName `liftM` getEnv
 623
 624 sameFileName :: SrcSpan -> TM a -> TM a -> TM a
 625 sameFileName pos out_of_scope in_scope = do
 626   file_name <- getFileName
 627   case optSrcSpanFileName pos of
 628     Just file_name2
 629       | file_name == file_name2 -> in_scope
 630     _ -> out_of_scope
 631
 632 bindLocals :: [Id] -> TM a -> TM a
 633 bindLocals new_ids (TM m)
 634   = TM $ \ env st ->
 635                  case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
 636                    (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
 637   where occs = [ nameOccName (idName id) | id <- new_ids ]
 638
 639 isBlackListed :: SrcSpan -> TM Bool
 640 isBlackListed pos = TM $ \ env st ->
 641               case lookupFM (blackList env) pos of
 642                 Nothing -> (False,noFVs,st)
 643                 Just () -> (True,noFVs,st)
 644
 645 -- the tick application inherits the source position of its
 646 -- expression argument to support nested box allocations
 647 allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
 648 allocTickBox boxLabel pos m | isGoodSrcSpan' pos =
 649   sameFileName pos
 650     (do e <- m; return (L pos e)) $ do
 651   (fvs, e) <- getFreeVars m
 652   TM $ \ env st ->
 653     let c = tickBoxCount st
 654         ids = occEnvElts fvs
 655         mes = mixEntries st
 656         me = (pos, map (nameOccName.idName) ids, boxLabel)
 657     in
 658     ( L pos (HsTick c ids (L pos e))
 659     , fvs
 660     , st {tickBoxCount=c+1,mixEntries=me:mes}
 661     )
 662 allocTickBox boxLabel pos m = do e <- m; return (L pos e)
 663
 664 -- the tick application inherits the source position of its
 665 -- expression argument to support nested box allocations
 666 allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
 667 allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos =
 668   sameFileName pos
 669     (return Nothing) $ TM $ \ env st ->
 670   let me = (pos, map (nameOccName.idName) ids, boxLabel)
 671       c = tickBoxCount st
 672       mes = mixEntries st
 673       ids = occEnvElts fvs
 674   in ( Just (c, ids)
 675      , noFVs
 676      , st {tickBoxCount=c+1, mixEntries=me:mes}
 677      )
 678 allocATickBox boxLabel pos fvs = return Nothing
 679
 680 allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 681 allocBinTickBox boxLabel (L pos e) | isGoodSrcSpan' pos = TM $ \ env st ->
 682   let meT = (pos,[],boxLabel True)
 683       meF = (pos,[],boxLabel False)
 684       meE = (pos,[],ExpBox False)
 685       c = tickBoxCount st
 686       mes = mixEntries st
 687   in
 688      if opt_Hpc
 689         then ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
 690            -- notice that F and T are reversed,
 691            -- because we are building the list in
 692            -- reverse...
 693              , noFVs
 694              , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
 695              )
 696         else
 697              ( L pos $ HsTick c [] $ L pos e
 698              , noFVs
 699              , st {tickBoxCount=c+1,mixEntries=meE:mes}
 700              )
 701
 702 allocBinTickBox boxLabel e = return e
 703
 704 isGoodSrcSpan' pos
 705    | not (isGoodSrcSpan pos) = False
 706    | start == end            = False
 707    | otherwise               = True
 708   where
 709    start = srcSpanStart pos
 710    end   = srcSpanEnd pos
 711
 712 mkHpcPos :: SrcSpan -> HpcPos
 713 mkHpcPos pos
 714    | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
 715    | otherwise                = hpcPos
 716   where
 717    start = srcSpanStart pos
 718    end   = srcSpanEnd pos
 719    hpcPos = toHpcPos ( srcLocLine start
 720                      , srcLocCol start + 1
 721                      , srcLocLine end
 722                      , srcLocCol end
 723                      )
 724
 725 noHpcPos = toHpcPos (0,0,0,0)
 726
 727 hpcSrcSpan = mkGeneralSrcSpan (FSLIT("Haskell Program Coverage internals"))
 728 \end{code}
 729
 730
 731 \begin{code}
 732 matchesOneOfMany :: [LMatch Id] -> Bool
 733 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
 734   where
 735         matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
 736 \end{code}
 737
 738
 739 \begin{code}
 740 type MixEntry_ = (SrcSpan, [OccName], BoxLabel)
 741
 742 -- For the hash value, we hash everything: the file name,
 743 --  the timestamp of the original source file, the tab stop,
 744 --  and the mix entries. We cheat, and hash the show'd string.
 745 -- This hash only has to be hashed at Mix creation time,
 746 -- and is for sanity checking only.
 747
 748 mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
 749 mixHash file tm tabstop entries = fromIntegral $ hashString
 750         (show $ Mix file tm 0 tabstop entries)
 751 \end{code}