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