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