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