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