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) = do
 270         (stmts', last_exp') <- addTickLStmts' forQual stmts
 271                                      (addTickLHsExpr last_exp)
 272         return (HsDo cxt stmts' last_exp' srcloc)
 273   where
 274         forQual = case cxt of
 275                     ListComp -> Just QualBinBox
 276                     _        -> Nothing
 277 addTickHsExpr (ExplicitList ty es) =
 278         liftM2 ExplicitList
 279                 (return ty)
 280                 (mapM (addTickLHsExpr) es)
 281 addTickHsExpr (ExplicitPArr      {}) = error "addTickHsExpr: ExplicitPArr"
 282 addTickHsExpr (ExplicitTuple es box) =
 283         liftM2 ExplicitTuple
 284                 (mapM (addTickLHsExpr) es)
 285                 (return box)
 286 addTickHsExpr (RecordCon         id ty rec_binds) =
 287         liftM3 RecordCon
 288                 (return id)
 289                 (return ty)
 290                 (addTickHsRecordBinds rec_binds)
 291 addTickHsExpr (RecordUpd        e rec_binds ty1 ty2) =
 292         liftM4 RecordUpd
 293                 (addTickLHsExpr e)
 294                 (addTickHsRecordBinds rec_binds)
 295                 (return ty1)
 296                 (return ty2)
 297 addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
 298 addTickHsExpr (ExprWithTySigOut e ty) =
 299         liftM2 ExprWithTySigOut
 300                 (addTickLHsExprNever e) -- No need to tick the inner expression
 301                                     -- for expressions with signatures
 302                 (return ty)
 303 addTickHsExpr (ArithSeq  ty arith_seq) =
 304         liftM2 ArithSeq
 305                 (return ty)
 306                 (addTickArithSeqInfo arith_seq)
 307 addTickHsExpr (HsTickPragma (file,(l1,c1),(l2,c2)) (L pos e0)) = do
 308     e2 <- allocTickBox (ExternalBox (unpackFS file) (P l1 c1 l2 c2)) pos $
 309                 addTickHsExpr e0
 310     return $ unLoc e2
 311 addTickHsExpr (PArrSeq   {}) = error "addTickHsExpr: PArrSeq"
 312 addTickHsExpr (HsSCC     {}) = error "addTickHsExpr: HsSCC"
 313 addTickHsExpr (HsCoreAnn   {}) = error "addTickHsExpr: HsCoreAnn"
 314 addTickHsExpr e@(HsBracket     {}) = return e
 315 addTickHsExpr e@(HsBracketOut  {}) = return e
 316 addTickHsExpr e@(HsSpliceE  {}) = return e
 317 addTickHsExpr (HsProc pat cmdtop) =
 318         liftM2 HsProc
 319                 (addTickLPat pat)
 320                 (liftL (addTickHsCmdTop) cmdtop)
 321 addTickHsExpr (HsWrap w e) =
 322         liftM2 HsWrap
 323                 (return w)
 324                 (addTickHsExpr e)       -- explicitly no tick on inside
 325 addTickHsExpr (HsArrApp  e1 e2 ty1 arr_ty lr) =
 326         liftM5 HsArrApp
 327                (addTickLHsExpr e1)
 328                (addTickLHsExpr e2)
 329                (return ty1)
 330                (return arr_ty)
 331                (return lr)
 332 addTickHsExpr (HsArrForm e fix cmdtop) =
 333         liftM3 HsArrForm
 334                (addTickLHsExpr e)
 335                (return fix)
 336                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 337
 338 addTickHsExpr e@(HsType ty) = return e
 339
 340 -- Should never happen in expression content.
 341 addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
 342 addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
 343 addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
 344 addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
 345 addTickHsExpr (HsTick _ _ _) = error "addTickhsExpr: HsTick _ _"
 346
 347 addTickMatchGroup (MatchGroup matches ty) = do
 348   let isOneOfMany = matchesOneOfMany matches
 349   matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
 350   return $ MatchGroup matches' ty
 351
 352 addTickMatch :: Bool -> Match Id -> TM (Match Id)
 353 addTickMatch isOneOfMany (Match pats opSig gRHSs) =
 354   bindLocals (collectPatsBinders pats) $ do
 355     gRHSs' <- addTickGRHSs isOneOfMany gRHSs
 356     return $ Match pats opSig gRHSs'
 357
 358 addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
 359 addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
 360   bindLocals binders $ do
 361     local_binds' <- addTickHsLocalBinds local_binds
 362     guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
 363     return $ GRHSs guarded' local_binds'
 364   where
 365     binders = map unLoc (collectLocalBinders local_binds)
 366
 367 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
 368 addTickGRHS isOneOfMany (GRHS stmts expr) = do
 369   (stmts',expr') <- addTickLStmts' (Just $ GuardBinBox) stmts
 370                         (if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
 371                                     else addTickLHsExprAlways expr)
 372   return $ GRHS stmts' expr'
 373
 374 addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
 375 addTickLStmts isGuard stmts = do
 376   (stmts, _) <- addTickLStmts' isGuard stmts (return ())
 377   return stmts
 378
 379 addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
 380                -> TM ([LStmt Id], a)
 381 addTickLStmts' isGuard lstmts res
 382   = bindLocals binders $ do
 383         lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
 384         a <- res
 385         return (lstmts', a)
 386   where
 387         binders = map unLoc (collectLStmtsBinders lstmts)
 388
 389 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
 390 addTickStmt isGuard (BindStmt pat e bind fail) = do
 391         liftM4 BindStmt
 392                 (addTickLPat pat)
 393                 (addTickLHsExprAlways e)
 394                 (addTickSyntaxExpr hpcSrcSpan bind)
 395                 (addTickSyntaxExpr hpcSrcSpan fail)
 396 addTickStmt isGuard (ExprStmt e bind' ty) = do
 397         liftM3 ExprStmt
 398                 (addTick e)
 399                 (addTickSyntaxExpr hpcSrcSpan bind')
 400                 (return ty)
 401   where
 402    addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
 403              | otherwise          = addTickLHsExprAlways e
 404
 405 addTickStmt isGuard (LetStmt binds) = do
 406         liftM LetStmt
 407                 (addTickHsLocalBinds binds)
 408 addTickStmt isGuard (ParStmt pairs) = do
 409         liftM ParStmt (mapM process pairs)
 410   where
 411         process (stmts,ids) =
 412                 liftM2 (,)
 413                         (addTickLStmts isGuard stmts)
 414                         (return ids)
 415 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
 416         liftM5 RecStmt
 417                 (addTickLStmts isGuard stmts)
 418                 (return ids1)
 419                 (return ids2)
 420                 (return tys)
 421                 (addTickDictBinds dictbinds)
 422
 423 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 424 addTickHsLocalBinds (HsValBinds binds) =
 425         liftM HsValBinds
 426                 (addTickHsValBinds binds)
 427 addTickHsLocalBinds (HsIPBinds binds)  =
 428         liftM HsIPBinds
 429                 (addTickHsIPBinds binds)
 430 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
 431
 432 addTickHsValBinds (ValBindsOut binds sigs) =
 433         liftM2 ValBindsOut
 434                 (mapM (\ (rec,binds') ->
 435                                 liftM2 (,)
 436                                         (return rec)
 437                                         (addTickLHsBinds binds'))
 438                         binds)
 439                 (return sigs)
 440
 441 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
 442         liftM2 IPBinds
 443                 (mapM (liftL (addTickIPBind)) ipbinds)
 444                 (addTickDictBinds dictbinds)
 445
 446 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 447 addTickIPBind (IPBind nm e) =
 448         liftM2 IPBind
 449                 (return nm)
 450                 (addTickLHsExpr e)
 451
 452 -- There is no location here, so we might need to use a context location??
 453 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
 454 addTickSyntaxExpr pos x = do
 455         L _ x' <- addTickLHsExpr (L pos x)
 456         return $ x'
 457 -- we do not walk into patterns.
 458 addTickLPat :: LPat Id -> TM (LPat Id)
 459 addTickLPat pat = return pat
 460
 461 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
 462 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 463         liftM4 HsCmdTop
 464                 (addTickLHsCmd cmd)
 465                 (return tys)
 466                 (return ty)
 467                 (return syntaxtable)
 468
 469 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 470 addTickLHsCmd x = addTickLHsExpr x
 471
 472 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
 473 addTickDictBinds x = addTickLHsBinds x
 474
 475 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 476 addTickHsRecordBinds (HsRecordBinds pairs) = liftM HsRecordBinds (mapM process pairs)
 477     where
 478         process (ids,expr) =
 479                 liftM2 (,)
 480                         (return ids)
 481                         (addTickLHsExpr expr)
 482
 483 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
 484 addTickArithSeqInfo (From e1) =
 485         liftM From
 486                 (addTickLHsExpr e1)
 487 addTickArithSeqInfo (FromThen e1 e2) =
 488         liftM2 FromThen
 489                 (addTickLHsExpr e1)
 490                 (addTickLHsExpr e2)
 491 addTickArithSeqInfo (FromTo e1 e2) =
 492         liftM2 FromTo
 493                 (addTickLHsExpr e1)
 494                 (addTickLHsExpr e2)
 495 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
 496         liftM3 FromThenTo
 497                 (addTickLHsExpr e1)
 498                 (addTickLHsExpr e2)
 499                 (addTickLHsExpr e3)
 500 \end{code}
 501
 502 \begin{code}
 503 data TickTransState = TT { modName     :: String
 504                          , declPath    :: [String]
 505                          , tickBoxCount:: Int
 506                          , mixEntries  :: [MixEntry]
 507                          , inScope     :: VarSet
 508                          }
 509 --      deriving Show
 510
 511 type FreeVars = OccEnv Id
 512 noFVs = emptyOccEnv
 513
 514 -- Note [freevars]
 515 --   For breakpoints we want to collect the free variables of an
 516 --   expression for pinning on the HsTick.  We don't want to collect
 517 --   *all* free variables though: in particular there's no point pinning
 518 --   on free variables that are will otherwise be in scope at the GHCi
 519 --   prompt, which means all top-level bindings.  Unfortunately detecting
 520 --   top-level bindings isn't easy (collectHsBindsBinders on the top-level
 521 --   bindings doesn't do it), so we keep track of a set of "in-scope"
 522 --   variables in addition to the free variables, and the former is used
 523 --   to filter additions to the latter.  This gives us complete control
 524 --   over what free variables we track.
 525
 526 data TM a = TM { unTM :: TickTransState -> (a,FreeVars,TickTransState) }
 527         -- a combination of a state monad (TickTransState) and a writer
 528         -- monad (FreeVars).
 529
 530 instance Monad TM where
 531   return a = TM $ \ st -> (a,noFVs,st)
 532   (TM m) >>= k = TM $ \ st -> case m st of
 533                                   (r1,fv1,st1) ->
 534                                      case unTM (k r1) st1 of
 535                                        (r2,fv2,st2) ->
 536                                           (r2, fv1 `plusOccEnv` fv2, st2)
 537
 538 getState :: TM TickTransState
 539 getState = TM $ \st -> (st, noFVs, st)
 540
 541 setState :: (TickTransState -> TickTransState) -> TM ()
 542 setState f = TM $ \st -> ((), noFVs, f st)
 543
 544 withState :: (TickTransState -> TickTransState) -> TM a -> TM a
 545 withState f (TM m) = TM $ \st -> case m (f st) of
 546                                    (a, fvs, st') -> (a, fvs, st')
 547
 548 getFreeVars :: TM a -> TM (FreeVars, a)
 549 getFreeVars (TM m)
 550   = TM $ \st -> case m st of (a, fv, st') -> ((fv,a), fv, st')
 551
 552 freeVar :: Id -> TM ()
 553 freeVar id = TM $ \st ->
 554                 if id `elemVarSet` inScope st
 555                    then ((), unitOccEnv (nameOccName (idName id)) id, st)
 556                    else ((), noFVs, st)
 557
 558 addPathEntry :: String -> TM a -> TM a
 559 addPathEntry nm = withState (\st -> st { declPath = declPath st ++ [nm] })
 560
 561 getPathEntry :: TM [String]
 562 getPathEntry = declPath `liftM` getState
 563
 564 bindLocals :: [Id] -> TM a -> TM a
 565 bindLocals new_ids (TM m)
 566   = TM $ \ st -> case m st{ inScope = inScope st `extendVarSetList` new_ids } of
 567                    (r, fv, st') -> (r, fv `delListFromUFM` occs, st')
 568   where occs = [ nameOccName (idName id) | id <- new_ids ]
 569
 570 -- the tick application inherits the source position of its
 571 -- expression argument to support nested box allocations
 572 allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
 573 allocTickBox boxLabel pos m | isGoodSrcSpan pos = do
 574   (fvs, e) <- getFreeVars m
 575   TM $ \st ->
 576     let c = tickBoxCount st
 577         ids = occEnvElts fvs
 578         mes = mixEntries st
 579         me = (pos, map (nameOccName.idName) ids, boxLabel)
 580     in
 581     ( L pos (HsTick c ids (L pos e))
 582     , fvs
 583     , st {tickBoxCount=c+1,mixEntries=me:mes}
 584     )
 585 allocTickBox boxLabel pos m = do e <- m; return (L pos e)
 586
 587 -- the tick application inherits the source position of its
 588 -- expression argument to support nested box allocations
 589 allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
 590 allocATickBox boxLabel pos fvs | isGoodSrcSpan pos = TM $ \ st ->
 591   let me = (pos, map (nameOccName.idName) ids, boxLabel)
 592       c = tickBoxCount st
 593       mes = mixEntries st
 594       ids = occEnvElts fvs
 595   in ( Just (c, ids)
 596      , noFVs
 597      , st {tickBoxCount=c+1, mixEntries=me:mes}
 598      )
 599 allocATickBox boxLabel pos fvs = return Nothing
 600
 601 allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 602 allocBinTickBox boxLabel (L pos e) | isGoodSrcSpan pos = TM $ \ st ->
 603   let meT = (pos,[],boxLabel True)
 604       meF = (pos,[],boxLabel False)
 605       meE = (pos,[],ExpBox)
 606       c = tickBoxCount st
 607       mes = mixEntries st
 608   in
 609      if opt_Hpc
 610         then ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
 611            -- notice that F and T are reversed,
 612            -- because we are building the list in
 613            -- reverse...
 614              , noFVs
 615              , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
 616              )
 617         else
 618              ( L pos $ HsTick c [] $ L pos e
 619              , noFVs
 620              , st {tickBoxCount=c+1,mixEntries=meE:mes}
 621              )
 622
 623 allocBinTickBox boxLabel e = return e
 624
 625 mkHpcPos :: SrcSpan -> Maybe HpcPos
 626 mkHpcPos pos
 627    | not (isGoodSrcSpan pos) = Nothing
 628    | start == end            = Nothing  -- no actual location
 629    | otherwise               = Just hpcPos
 630   where
 631    start = srcSpanStart pos
 632    end   = srcSpanEnd pos
 633    hpcPos = toHpcPos ( srcLocLine start
 634                      , srcLocCol start
 635                      , srcLocLine end
 636                      , srcLocCol end
 637                      )
 638
 639 hpcSrcSpan = mkGeneralSrcSpan (FSLIT("Haskell Program Coverage internals"))
 640 \end{code}
 641
 642
 643 \begin{code}
 644 matchesOneOfMany :: [LMatch Id] -> Bool
 645 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
 646   where
 647         matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
 648 \end{code}
 649
 650
 651 \begin{code}
 652 ---------------------------------------------------------------
 653 -- Datatypes and file-access routines for the per-module (.mix)
 654 -- indexes used by Hpc.
 655 -- Colin Runciman and Andy Gill, June 2006
 656 ---------------------------------------------------------------
 657
 658 -- a module index records the attributes of each tick-box that has
 659 -- been introduced in that module, accessed by tick-number position
 660 -- in the list
 661
 662 data Mix = Mix
 663              FilePath           -- location of original file
 664              Integer            -- time (in seconds) of original file's last update, since 1970.
 665              Int                -- tab stop value
 666              [MixEntry_]        -- entries
 667         deriving (Show, Read)
 668
 669 -- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
 670 -- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
 671 -- because if some other program also defined that instance, we will not be able to compile.
 672
 673 type MixEntry  = (SrcSpan, [OccName], BoxLabel)
 674 type MixEntry_ = (HpcPos, BoxLabel)
 675
 676 data BoxLabel = ExpBox
 677               | AltBox
 678               | TopLevelBox [String]
 679               | LocalBox [String]
 680               | GuardBinBox Bool
 681               | CondBinBox Bool
 682               | QualBinBox Bool
 683               | ExternalBox String HpcPos
 684                    -- ^The position was generated from the named file/module,
 685                    -- with the stated position (inside the named file/module).
 686                    -- The HpcPos inside this MixEntry refers to the generated Haskell location.
 687               deriving (Read, Show)
 688
 689 mixCreate :: String -> String -> Mix -> IO ()
 690 mixCreate dirName modName mix =
 691    writeFile (mixName dirName modName) (show mix)
 692
 693 mixName :: FilePath -> String -> String
 694 mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
 695
 696 getModificationTime' :: FilePath -> IO Integer
 697 getModificationTime' file = do
 698   (TOD sec _) <- System.Directory.getModificationTime file
 699   return $ sec
 700
 701 -- a program index records module names and numbers of tick-boxes
 702 -- introduced in each module that has been transformed for coverage
 703
 704 data HpcPos = P !Int !Int !Int !Int deriving (Eq)
 705
 706 toHpcPos :: (Int,Int,Int,Int) -> HpcPos
 707 toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
 708
 709 instance Show HpcPos where
 710    show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
 711
 712 instance Read HpcPos where
 713   readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
 714       where
 715          (before,after)   = span (/= ',') pos
 716          (lhs,rhs)    = case span (/= '-') before of
 717                                (lhs,'-':rhs) -> (lhs,rhs)
 718                                (lhs,"")      -> (lhs,lhs)
 719          (l1,':':c1)      = span (/= ':') lhs
 720          (l2,':':c2)      = span (/= ':') rhs
 721
 722 \end{code}
 723