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