compiler/deSugar/Coverage.lhs

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