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