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