Add tuple sections as a new feature
[ghc.git] / compiler / deSugar / Coverage.lhs
1 %
2 % (c) Galois, 2006
3 % (c) University of Glasgow, 2007
4 %
5 \section[Coverage]{@coverage@: the main function}
6
7 \begin{code}
8 module Coverage (addCoverageTicksToBinds) where
9
10 import HsSyn
11 import Module
12 import Outputable
13 import DynFlags
14 import Monad            
15 import SrcLoc
16 import ErrUtils
17 import Name
18 import Bag
19 import Id
20 import VarSet
21 import Data.List
22 import FastString
23 import HscTypes 
24 import StaticFlags
25 import TyCon
26 import FiniteMap
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 \end{code}
38
39
40 %************************************************************************
41 %*                                                                      *
42 %*              The main function: addCoverageTicksToBinds
43 %*                                                                      *
44 %************************************************************************
45
46 \begin{code}
47 addCoverageTicksToBinds
48         :: DynFlags
49         -> Module
50         -> ModLocation          -- of the current module
51         -> [TyCon]              -- type constructor in this module
52         -> LHsBinds Id
53         -> IO (LHsBinds Id, HpcInfo, ModBreaks)
54
55 addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do 
56
57   let orig_file = 
58              case ml_hs_file mod_loc of
59                     Just file -> file
60                     Nothing -> panic "can not find the original file during hpc trans"
61
62   if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
63
64   -- 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    = listToFM [ (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 (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
143   abs_binds' <- addTickLHsBinds abs_binds
144   return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_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      e1 e2 e3) = 
290         liftM3 HsIf
291                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
292                 (addTickLHsExprOptAlt True e2)
293                 (addTickLHsExprOptAlt True e3)
294 addTickHsExpr (HsLet binds e) =
295         bindLocals (map unLoc $ 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 = map unLoc (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 = map unLoc (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 addTickStmt isGuard (TransformStmt (stmts, ids) usingExpr maybeByExpr) = do
446     liftM3 TransformStmt 
447         (addTickStmtAndBinders isGuard (stmts, ids))
448         (addTickLHsExprAlways usingExpr)
449         (addTickMaybeByLHsExpr maybeByExpr)
450 addTickStmt isGuard (GroupStmt (stmts, binderMap) groupByClause) = do
451     liftM2 GroupStmt 
452         (addTickStmtAndBinders isGuard (stmts, binderMap))
453         (case groupByClause of
454             GroupByNothing usingExpr -> addTickLHsExprAlways usingExpr >>= (return . GroupByNothing)
455             GroupBySomething eitherUsingExpr byExpr -> do
456                 eitherUsingExpr' <- mapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) eitherUsingExpr
457                 byExpr' <- addTickLHsExprAlways byExpr
458                 return $ GroupBySomething eitherUsingExpr' byExpr')
459     where
460         mapEitherM f g x = do
461           case x of
462             Left a -> f a >>= (return . Left)
463             Right b -> g b >>= (return . Right)
464 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
465         liftM5 RecStmt 
466                 (addTickLStmts isGuard stmts)
467                 (return ids1)
468                 (return ids2)
469                 (return tys)
470                 (addTickDictBinds dictbinds)
471
472 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
473 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
474                   | otherwise          = addTickLHsExprAlways e
475
476 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a) 
477                       -> TM ([LStmt Id], a)
478 addTickStmtAndBinders isGuard (stmts, ids) = 
479     liftM2 (,) 
480         (addTickLStmts isGuard stmts)
481         (return ids)
482
483 addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
484 addTickMaybeByLHsExpr maybeByExpr = 
485     case maybeByExpr of
486         Nothing -> return Nothing
487         Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
488
489 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
490 addTickHsLocalBinds (HsValBinds binds) = 
491         liftM HsValBinds 
492                 (addTickHsValBinds binds)
493 addTickHsLocalBinds (HsIPBinds binds)  = 
494         liftM HsIPBinds 
495                 (addTickHsIPBinds binds)
496 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
497
498 addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
499 addTickHsValBinds (ValBindsOut binds sigs) =
500         liftM2 ValBindsOut
501                 (mapM (\ (rec,binds') -> 
502                                 liftM2 (,)
503                                         (return rec)
504                                         (addTickLHsBinds binds'))
505                         binds)
506                 (return sigs)
507 addTickHsValBinds _ = panic "addTickHsValBinds"
508
509 addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
510 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
511         liftM2 IPBinds
512                 (mapM (liftL (addTickIPBind)) ipbinds)
513                 (addTickDictBinds dictbinds)
514
515 addTickIPBind :: IPBind Id -> TM (IPBind Id)
516 addTickIPBind (IPBind nm e) =
517         liftM2 IPBind
518                 (return nm)
519                 (addTickLHsExpr e)
520
521 -- There is no location here, so we might need to use a context location??
522 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
523 addTickSyntaxExpr pos x = do
524         L _ x' <- addTickLHsExpr (L pos x)
525         return $ x'
526 -- we do not walk into patterns.
527 addTickLPat :: LPat Id -> TM (LPat Id)
528 addTickLPat pat = return pat
529
530 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
531 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
532         liftM4 HsCmdTop
533                 (addTickLHsCmd cmd)
534                 (return tys)
535                 (return ty)
536                 (return syntaxtable)
537
538 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
539 addTickLHsCmd x = addTickLHsExpr x
540
541 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
542 addTickDictBinds x = addTickLHsBinds x
543
544 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
545 addTickHsRecordBinds (HsRecFields fields dd) 
546   = do  { fields' <- mapM process fields
547         ; return (HsRecFields fields' dd) }
548   where
549     process (HsRecField ids expr doc)
550         = do { expr' <- addTickLHsExpr expr
551              ; return (HsRecField ids expr' doc) }
552
553 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
554 addTickArithSeqInfo (From e1) =
555         liftM From
556                 (addTickLHsExpr e1)
557 addTickArithSeqInfo (FromThen e1 e2) =
558         liftM2 FromThen
559                 (addTickLHsExpr e1)
560                 (addTickLHsExpr e2)
561 addTickArithSeqInfo (FromTo e1 e2) =
562         liftM2 FromTo
563                 (addTickLHsExpr e1)
564                 (addTickLHsExpr e2)
565 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
566         liftM3 FromThenTo
567                 (addTickLHsExpr e1)
568                 (addTickLHsExpr e2)
569                 (addTickLHsExpr e3)
570 \end{code}
571
572 \begin{code}
573 data TickTransState = TT { tickBoxCount:: Int
574                          , mixEntries  :: [MixEntry_]
575                          }                        
576
577 data TickTransEnv = TTE { fileName      :: FastString
578                         , declPath     :: [String]
579                         , inScope      :: VarSet
580                         , blackList   :: FiniteMap SrcSpan ()
581                         }
582
583 --      deriving Show
584
585 type FreeVars = OccEnv Id
586 noFVs :: FreeVars
587 noFVs = emptyOccEnv
588
589 -- Note [freevars]
590 --   For breakpoints we want to collect the free variables of an
591 --   expression for pinning on the HsTick.  We don't want to collect
592 --   *all* free variables though: in particular there's no point pinning
593 --   on free variables that are will otherwise be in scope at the GHCi
594 --   prompt, which means all top-level bindings.  Unfortunately detecting
595 --   top-level bindings isn't easy (collectHsBindsBinders on the top-level
596 --   bindings doesn't do it), so we keep track of a set of "in-scope"
597 --   variables in addition to the free variables, and the former is used
598 --   to filter additions to the latter.  This gives us complete control
599 --   over what free variables we track.
600
601 data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
602         -- a combination of a state monad (TickTransState) and a writer
603         -- monad (FreeVars).
604
605 instance Monad TM where
606   return a = TM $ \ _env st -> (a,noFVs,st)
607   (TM m) >>= k = TM $ \ env st -> 
608                                 case m env st of
609                                   (r1,fv1,st1) -> 
610                                      case unTM (k r1) env st1 of
611                                        (r2,fv2,st2) -> 
612                                           (r2, fv1 `plusOccEnv` fv2, st2)
613
614 -- getState :: TM TickTransState
615 -- getState = TM $ \ env st -> (st, noFVs, st)
616
617 -- setState :: (TickTransState -> TickTransState) -> TM ()
618 -- setState f = TM $ \ env st -> ((), noFVs, f st)
619
620 getEnv :: TM TickTransEnv
621 getEnv = TM $ \ env st -> (env, noFVs, st)
622
623 withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
624 withEnv f (TM m) = TM $ \ env st -> 
625                                  case m (f env) st of
626                                    (a, fvs, st') -> (a, fvs, st')
627
628 getFreeVars :: TM a -> TM (FreeVars, a)
629 getFreeVars (TM m) 
630   = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
631
632 freeVar :: Id -> TM ()
633 freeVar id = TM $ \ env st -> 
634                 if id `elemVarSet` inScope env
635                    then ((), unitOccEnv (nameOccName (idName id)) id, st)
636                    else ((), noFVs, st)
637
638 addPathEntry :: String -> TM a -> TM a
639 addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
640
641 getPathEntry :: TM [String]
642 getPathEntry = declPath `liftM` getEnv
643
644 getFileName :: TM FastString
645 getFileName = fileName `liftM` getEnv
646
647 sameFileName :: SrcSpan -> TM a -> TM a -> TM a
648 sameFileName pos out_of_scope in_scope = do
649   file_name <- getFileName
650   case srcSpanFileName_maybe pos of 
651     Just file_name2 
652       | file_name == file_name2 -> in_scope
653     _ -> out_of_scope
654
655 bindLocals :: [Id] -> TM a -> TM a
656 bindLocals new_ids (TM m)
657   = TM $ \ env st -> 
658                  case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
659                    (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
660   where occs = [ nameOccName (idName id) | id <- new_ids ] 
661
662 isBlackListed :: SrcSpan -> TM Bool
663 isBlackListed pos = TM $ \ env st -> 
664               case lookupFM (blackList env) pos of
665                 Nothing -> (False,noFVs,st)
666                 Just () -> (True,noFVs,st)
667
668 -- the tick application inherits the source position of its
669 -- expression argument to support nested box allocations 
670 allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
671 allocTickBox boxLabel pos m | isGoodSrcSpan' pos = 
672   sameFileName pos 
673     (do e <- m; return (L pos e)) $ do
674   (fvs, e) <- getFreeVars m
675   TM $ \ _env st ->
676     let c = tickBoxCount st
677         ids = occEnvElts fvs
678         mes = mixEntries st
679         me = (pos, map (nameOccName.idName) ids, boxLabel)
680     in
681     ( L pos (HsTick c ids (L pos e))
682     , fvs
683     , st {tickBoxCount=c+1,mixEntries=me:mes}
684     )
685 allocTickBox _boxLabel pos m = do e <- m; return (L pos e)
686
687 -- the tick application inherits the source position of its
688 -- expression argument to support nested box allocations 
689 allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
690 allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = 
691   sameFileName pos 
692     (return Nothing) $ TM $ \ _env st ->
693   let me = (pos, map (nameOccName.idName) ids, boxLabel)
694       c = tickBoxCount st
695       mes = mixEntries st
696       ids = occEnvElts fvs
697   in ( Just (c, ids)
698      , noFVs
699      , st {tickBoxCount=c+1, mixEntries=me:mes}
700      )
701 allocATickBox _boxLabel _pos _fvs = return Nothing
702
703 allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
704                 -> TM (LHsExpr Id)
705 allocBinTickBox boxLabel pos m
706  | not opt_Hpc = allocTickBox (ExpBox False) pos m
707  | isGoodSrcSpan' pos =
708  do
709  e <- m
710  TM $ \ _env st ->
711   let meT = (pos,[],boxLabel True)
712       meF = (pos,[],boxLabel False)
713       meE = (pos,[],ExpBox False)
714       c = tickBoxCount st
715       mes = mixEntries st
716   in 
717              ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
718            -- notice that F and T are reversed,
719            -- because we are building the list in
720            -- reverse...
721              , noFVs
722              , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
723              )
724 allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
725
726 isGoodSrcSpan' :: SrcSpan -> Bool
727 isGoodSrcSpan' pos
728    | not (isGoodSrcSpan pos) = False
729    | start == end            = False
730    | otherwise               = True
731   where
732    start = srcSpanStart pos
733    end   = srcSpanEnd pos
734
735 mkHpcPos :: SrcSpan -> HpcPos
736 mkHpcPos pos 
737    | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
738    | otherwise                = hpcPos
739   where
740    start = srcSpanStart pos
741    end   = srcSpanEnd pos
742    hpcPos = toHpcPos ( srcLocLine start
743                      , srcLocCol start + 1
744                      , srcLocLine end
745                      , srcLocCol end
746                      )
747
748 hpcSrcSpan :: SrcSpan
749 hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
750 \end{code}
751
752
753 \begin{code}
754 matchesOneOfMany :: [LMatch Id] -> Bool
755 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
756   where
757         matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
758 \end{code}
759
760
761 \begin{code}
762 type MixEntry_ = (SrcSpan, [OccName], BoxLabel)
763
764 -- For the hash value, we hash everything: the file name, 
765 --  the timestamp of the original source file, the tab stop,
766 --  and the mix entries. We cheat, and hash the show'd string.
767 -- This hash only has to be hashed at Mix creation time,
768 -- and is for sanity checking only.
769
770 mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
771 mixHash file tm tabstop entries = fromIntegral $ hashString
772         (show $ Mix file tm 0 tabstop entries)
773 \end{code}