compiler/deSugar/Coverage.lhs

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