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