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 addTickLHsExprNeverOrAlways :: LHsExpr Id -> TM (LHsExpr Id)
 168 addTickLHsExprNeverOrAlways e
 169     | opt_Hpc   = addTickLHsExprNever e
 170     | otherwise = addTickLHsExprAlways e
 171
 172 addTickLHsExprNeverOrMaybe :: LHsExpr Id -> TM (LHsExpr Id)
 173 addTickLHsExprNeverOrMaybe e
 174     | opt_Hpc   = addTickLHsExprNever e
 175     | otherwise = addTickLHsExpr e
 176
 177 -- version of addTick that does not actually add a tick,
 178 -- because the scope of this tick is completely subsumed by
 179 -- another.
 180 addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
 181 addTickLHsExprNever (L pos e0) = do
 182     e1 <- addTickHsExpr e0
 183     return $ L pos e1
 184
 185 -- selectively add ticks to interesting expressions
 186 addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
 187 addTickLHsExpr (L pos e0) = do
 188     e1 <- addTickHsExpr e0
 189     if opt_Hpc || isGoodBreakExpr e0
 190        then do
 191           fn <- allocTickBox ExpBox pos
 192           return $ fn $ L pos e1
 193        else
 194           return $ L pos e1
 195
 196 -- general heuristic: expressions which do not denote values are good break points
 197 isGoodBreakExpr :: HsExpr Id -> Bool
 198 isGoodBreakExpr (HsApp {})     = True
 199 isGoodBreakExpr (OpApp {})     = True
 200 isGoodBreakExpr (NegApp {})    = True
 201 isGoodBreakExpr (HsCase {})    = True
 202 isGoodBreakExpr (HsIf {})      = True
 203 isGoodBreakExpr (RecordCon {}) = True
 204 isGoodBreakExpr (RecordUpd {}) = True
 205 isGoodBreakExpr (ArithSeq {})  = True
 206 isGoodBreakExpr (PArrSeq {})   = True
 207 isGoodBreakExpr other          = False
 208
 209 addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
 210 addTickLHsExprOptAlt oneOfMany (L pos e0)
 211   | not opt_Hpc = addTickLHsExpr (L pos e0)
 212   | otherwise = do
 213     e1 <- addTickHsExpr e0
 214     fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos
 215     return $ fn $ L 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                 (addTickLHsExprNeverOrAlways e)
 263 addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
 264         liftM4 HsDo
 265                 (return cxt)
 266                 (mapM (liftL (addTickStmt forQual)) stmts)
 267                 (addTickLHsExpr last_exp)
 268                 (return srcloc)
 269   where
 270         forQual = case cxt of
 271                     ListComp -> Just QualBinBox
 272                     _        -> Nothing
 273 addTickHsExpr (ExplicitList ty es) =
 274         liftM2 ExplicitList
 275                 (return ty)
 276                 (mapM (addTickLHsExpr) es)
 277 addTickHsExpr (ExplicitPArr      {}) = error "addTickHsExpr: ExplicitPArr"
 278 addTickHsExpr (ExplicitTuple es box) =
 279         liftM2 ExplicitTuple
 280                 (mapM (addTickLHsExpr) es)
 281                 (return box)
 282 addTickHsExpr (RecordCon         id ty rec_binds) =
 283         liftM3 RecordCon
 284                 (return id)
 285                 (return ty)
 286                 (addTickHsRecordBinds rec_binds)
 287 addTickHsExpr (RecordUpd        e rec_binds ty1 ty2) =
 288         liftM4 RecordUpd
 289                 (addTickLHsExpr e)
 290                 (addTickHsRecordBinds rec_binds)
 291                 (return ty1)
 292                 (return ty2)
 293 addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
 294 addTickHsExpr (ExprWithTySigOut e ty) =
 295         liftM2 ExprWithTySigOut
 296                 (addTickLHsExprNever e) -- No need to tick the inner expression
 297                                     -- for expressions with signatures
 298                 (return ty)
 299 addTickHsExpr (ArithSeq  ty arith_seq) =
 300         liftM2 ArithSeq
 301                 (return ty)
 302                 (addTickArithSeqInfo arith_seq)
 303 addTickHsExpr (HsTickPragma (file,(l1,c1),(l2,c2)) (L pos e0)) = do
 304     e1 <- addTickHsExpr e0
 305     fn <- allocTickBox (ExternalBox (unpackFS file) (P l1 c1 l2 c2)) pos
 306     let (L _ e2) = fn $ L pos e1
 307     return $ 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) = do
 351   gRHSs' <- addTickGRHSs isOneOfMany gRHSs
 352   return $ Match pats opSig gRHSs'
 353
 354 addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
 355 addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
 356   guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
 357   local_binds' <- addTickHsLocalBinds local_binds
 358   return $ GRHSs guarded' local_binds'
 359
 360 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
 361 addTickGRHS isOneOfMany (GRHS stmts expr) = do
 362   stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts
 363   expr' <- if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
 364                       else addTickLHsExprAlways expr
 365   return $ GRHS stmts' expr'
 366
 367 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
 368 addTickStmt isGuard (BindStmt pat e bind fail) =
 369         liftM4 BindStmt
 370                 (addTickLPat pat)
 371                 (addTickLHsExprAlways e)
 372                 (addTickSyntaxExpr hpcSrcSpan bind)
 373                 (addTickSyntaxExpr hpcSrcSpan fail)
 374 addTickStmt isGuard (ExprStmt e bind' ty) =
 375         liftM3 ExprStmt
 376                 (addTick e)
 377                 (addTickSyntaxExpr hpcSrcSpan bind')
 378                 (return ty)
 379   where
 380    addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
 381              | otherwise          = addTickLHsExprAlways e
 382
 383 addTickStmt isGuard (LetStmt binds) =
 384         liftM LetStmt
 385                 (addTickHsLocalBinds binds)
 386 addTickStmt isGuard (ParStmt pairs) =
 387         liftM ParStmt (mapM process pairs)
 388   where
 389         process (stmts,ids) =
 390                 liftM2 (,)
 391                         (mapM (liftL (addTickStmt isGuard)) stmts)
 392                         (return ids)
 393 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) =
 394         liftM5 RecStmt
 395                 (mapM (liftL (addTickStmt isGuard)) stmts)
 396                 (return ids1)
 397                 (return ids2)
 398                 (return tys)
 399                 (addTickDictBinds dictbinds)
 400
 401 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 402 addTickHsLocalBinds (HsValBinds binds) =
 403         liftM HsValBinds
 404                 (addTickHsValBinds binds)
 405 addTickHsLocalBinds (HsIPBinds binds)  =
 406         liftM HsIPBinds
 407                 (addTickHsIPBinds binds)
 408 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
 409
 410 addTickHsValBinds (ValBindsOut binds sigs) =
 411         liftM2 ValBindsOut
 412                 (mapM (\ (rec,binds') ->
 413                                 liftM2 (,)
 414                                         (return rec)
 415                                         (addTickLHsBinds binds'))
 416                         binds)
 417                 (return sigs)
 418
 419 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
 420         liftM2 IPBinds
 421                 (mapM (liftL (addTickIPBind)) ipbinds)
 422                 (addTickDictBinds dictbinds)
 423
 424 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 425 addTickIPBind (IPBind nm e) =
 426         liftM2 IPBind
 427                 (return nm)
 428                 (addTickLHsExpr e)
 429
 430 -- There is no location here, so we might need to use a context location??
 431 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
 432 addTickSyntaxExpr pos x = do
 433         L _ x' <- addTickLHsExpr (L pos x)
 434         return $ x'
 435 -- we do not walk into patterns.
 436 addTickLPat :: LPat Id -> TM (LPat Id)
 437 addTickLPat pat = return pat
 438
 439 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
 440 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 441         liftM4 HsCmdTop
 442                 (addTickLHsCmd cmd)
 443                 (return tys)
 444                 (return ty)
 445                 (return syntaxtable)
 446
 447 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 448 addTickLHsCmd x = addTickLHsExpr x
 449
 450 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
 451 addTickDictBinds x = addTickLHsBinds x
 452
 453 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 454 addTickHsRecordBinds (HsRecordBinds pairs) = liftM HsRecordBinds (mapM process pairs)
 455     where
 456         process (ids,expr) =
 457                 liftM2 (,)
 458                         (return ids)
 459                         (addTickLHsExpr expr)
 460
 461 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
 462 addTickArithSeqInfo (From e1) =
 463         liftM From
 464                 (addTickLHsExpr e1)
 465 addTickArithSeqInfo (FromThen e1 e2) =
 466         liftM2 FromThen
 467                 (addTickLHsExpr e1)
 468                 (addTickLHsExpr e2)
 469 addTickArithSeqInfo (FromTo e1 e2) =
 470         liftM2 FromTo
 471                 (addTickLHsExpr e1)
 472                 (addTickLHsExpr e2)
 473 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
 474         liftM3 FromThenTo
 475                 (addTickLHsExpr e1)
 476                 (addTickLHsExpr e2)
 477                 (addTickLHsExpr e3)
 478 \end{code}
 479
 480 \begin{code}
 481 data TickTransState = TT { modName     :: String
 482                          , declPath    :: [String]
 483                          , tickBoxCount:: Int
 484                          , mixEntries  :: [MixEntry]
 485                          }
 486         deriving Show
 487
 488 data TM a = TM { unTM :: TickTransState -> (a,TickTransState) }
 489
 490 instance Monad TM where
 491   return a = TM $ \ st -> (a,st)
 492   (TM m) >>= k = TM $ \ st -> case m st of
 493                                 (r1,st1) -> unTM (k r1) st1
 494
 495 --addTick :: LHsExpr Id -> TM (LHsExpr Id)
 496 --addTick e = TM $ \ uq -> (e,succ uq,[(uq,getLoc e)])
 497
 498 addPathEntry :: String -> TM a -> TM a
 499 addPathEntry nm (TM m) = TM $ \ st -> case m (st { declPath = declPath st ++ [nm] }) of
 500                                         (r,st') -> (r,st' { declPath = declPath st })
 501
 502 getPathEntry :: TM [String]
 503 getPathEntry = TM $ \ st -> (declPath st,st)
 504
 505 -- the tick application inherits the source position of its
 506 -- expression argument to support nested box allocations
 507 allocTickBox :: BoxLabel -> SrcSpan -> TM (LHsExpr Id -> LHsExpr Id)
 508 allocTickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
 509   let me = (hpcPos,boxLabel)
 510       c = tickBoxCount st
 511       mes = mixEntries st
 512   in ( \ (L pos e) -> L pos $ HsTick c (L pos e)
 513      , st {tickBoxCount=c+1,mixEntries=me:mes}
 514      )
 515 allocTickBox boxLabel e = return id
 516
 517 -- the tick application inherits the source position of its
 518 -- expression argument to support nested box allocations
 519 allocATickBox :: BoxLabel -> SrcSpan -> TM (Maybe Int)
 520 allocATickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
 521   let me = (hpcPos,boxLabel)
 522       c = tickBoxCount st
 523       mes = mixEntries st
 524   in ( Just c
 525      , st {tickBoxCount=c+1,mixEntries=me:mes}
 526      )
 527 allocATickBox boxLabel e = return Nothing
 528
 529 allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 530 allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
 531   let meT = (hpcPos,boxLabel True)
 532       meF = (hpcPos,boxLabel False)
 533       meE = (hpcPos,ExpBox)
 534       c = tickBoxCount st
 535       mes = mixEntries st
 536   in
 537      if opt_Hpc
 538         then ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
 539            -- notice that F and T are reversed,
 540            -- because we are building the list in
 541            -- reverse...
 542              , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
 543              )
 544         else
 545              ( L pos $ HsTick c $ L pos e
 546              , st {tickBoxCount=c+1,mixEntries=meE:mes}
 547              )
 548
 549 allocBinTickBox boxLabel e = return e
 550
 551 mkHpcPos :: SrcSpan -> Maybe HpcPos
 552 mkHpcPos pos
 553    | not (isGoodSrcSpan pos) = Nothing
 554    | start == end            = Nothing  -- no actual location
 555    | otherwise               = Just hpcPos
 556   where
 557    start = srcSpanStart pos
 558    end   = srcSpanEnd pos
 559    hpcPos = toHpcPos ( srcLocLine start
 560                      , srcLocCol start
 561                      , srcLocLine end
 562                      , srcLocCol end
 563                      )
 564
 565 hpcSrcSpan = mkGeneralSrcSpan (FSLIT("Haskell Program Coverage internals"))
 566 \end{code}
 567
 568
 569 \begin{code}
 570 matchesOneOfMany :: [LMatch Id] -> Bool
 571 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
 572   where
 573         matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
 574 \end{code}
 575
 576
 577 \begin{code}
 578 ---------------------------------------------------------------
 579 -- Datatypes and file-access routines for the per-module (.mix)
 580 -- indexes used by Hpc.
 581 -- Colin Runciman and Andy Gill, June 2006
 582 ---------------------------------------------------------------
 583
 584 -- a module index records the attributes of each tick-box that has
 585 -- been introduced in that module, accessed by tick-number position
 586 -- in the list
 587
 588 data Mix = Mix
 589              FilePath           -- location of original file
 590              Integer            -- time (in seconds) of original file's last update, since 1970.
 591              Int                -- tab stop value
 592              [MixEntry]         -- entries
 593         deriving (Show,Read)
 594
 595 -- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
 596 -- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
 597 -- because if some other program also defined that instance, we will not be able to compile.
 598
 599 type MixEntry = (HpcPos, BoxLabel)
 600
 601 data BoxLabel = ExpBox
 602               | AltBox
 603               | TopLevelBox [String]
 604               | LocalBox [String]
 605               | GuardBinBox Bool
 606               | CondBinBox Bool
 607               | QualBinBox Bool
 608               | ExternalBox String HpcPos
 609                    -- ^The position was generated from the named file/module,
 610                    -- with the stated position (inside the named file/module).
 611                    -- The HpcPos inside this MixEntry refers to the generated Haskell location.
 612               deriving (Read, Show)
 613
 614 mixCreate :: String -> String -> Mix -> IO ()
 615 mixCreate dirName modName mix =
 616    writeFile (mixName dirName modName) (show mix)
 617
 618 mixName :: FilePath -> String -> String
 619 mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
 620
 621 getModificationTime' :: FilePath -> IO Integer
 622 getModificationTime' file = do
 623   (TOD sec _) <- System.Directory.getModificationTime file
 624   return $ sec
 625
 626 -- a program index records module names and numbers of tick-boxes
 627 -- introduced in each module that has been transformed for coverage
 628
 629 data HpcPos = P !Int !Int !Int !Int deriving (Eq)
 630
 631 toHpcPos :: (Int,Int,Int,Int) -> HpcPos
 632 toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
 633
 634 instance Show HpcPos where
 635    show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
 636
 637 instance Read HpcPos where
 638   readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
 639       where
 640          (before,after)   = span (/= ',') pos
 641          (lhs,rhs)    = case span (/= '-') before of
 642                                (lhs,'-':rhs) -> (lhs,rhs)
 643                                (lhs,"")      -> (lhs,lhs)
 644          (l1,':':c1)      = span (/= ':') lhs
 645          (l2,':':c2)      = span (/= ':') rhs
 646
 647 \end{code}
 648