compiler/deSugar/Coverage.lhs

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