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