← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to compiler/deSugar/Coverage.lhs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

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