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