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