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  {}) = error "addTickHsExpr:  HsArrApp  "
 270 addTickHsExpr (HsArrForm {}) = error "addTickHsExpr:  HsArrForm"
 271 addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
 272 addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
 273 addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
 274 addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
 275 addTickHsExpr (HsTick _ _) = error "addTickhsExpr: HsTick _ _"
 276
 277 addTickHsExpr e@(HsType ty) = return e
 278
 279 -- catch all, and give an error message.
 280 --addTickHsExpr e = error ("addTickLhsExpr: " ++ showSDoc (ppr e))
 281
 282
 283 addTickMatchGroup (MatchGroup matches ty) = do
 284   let isOneOfMany = True -- AJG: for now
 285   matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
 286   return $ MatchGroup matches' ty
 287
 288 addTickMatch :: Bool -> Match Id -> TM (Match Id)
 289 addTickMatch isOneOfMany (Match pats opSig gRHSs) = do
 290   gRHSs' <- addTickGRHSs isOneOfMany gRHSs
 291   return $ Match pats opSig gRHSs'
 292
 293 addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
 294 addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
 295   guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
 296   local_binds' <- addTickHsLocalBinds local_binds
 297   return $ GRHSs guarded' local_binds'
 298
 299 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
 300 addTickGRHS isOneOfMany (GRHS stmts expr) = do
 301   stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts
 302   expr' <- addTickLHsExprOptAlt isOneOfMany expr
 303   return $ GRHS stmts' expr'
 304
 305
 306 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
 307 addTickStmt isGuard (BindStmt pat e bind fail) =
 308         liftM4 BindStmt
 309                 (addTickLPat pat)
 310                 (addTickLHsExpr e)
 311                 (addTickSyntaxExpr hpcSrcSpan bind)
 312                 (addTickSyntaxExpr hpcSrcSpan fail)
 313 addTickStmt isGuard (ExprStmt e bind' ty) =
 314         liftM3 ExprStmt
 315                 (addTick e)
 316                 (addTickSyntaxExpr hpcSrcSpan bind')
 317                 (return ty)
 318   where
 319         addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
 320                   | otherwise          = addTickLHsExpr e
 321
 322 addTickStmt isGuard (LetStmt binds) =
 323         liftM LetStmt
 324                 (addTickHsLocalBinds binds)
 325 addTickStmt isGuard (ParStmt pairs) =
 326         liftM ParStmt (mapM process pairs)
 327   where
 328         process (stmts,ids) =
 329                 liftM2 (,)
 330                         (mapM (liftL (addTickStmt isGuard)) stmts)
 331                         (return ids)
 332 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) =
 333         liftM5 RecStmt
 334                 (mapM (liftL (addTickStmt isGuard)) stmts)
 335                 (return ids1)
 336                 (return ids2)
 337                 (return tys)
 338                 (addTickDictBinds dictbinds)
 339
 340 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 341 addTickHsLocalBinds (HsValBinds binds) =
 342         liftM HsValBinds
 343                 (addTickHsValBinds binds)
 344 addTickHsLocalBinds (HsIPBinds binds)  =
 345         liftM HsIPBinds
 346                 (addTickHsIPBinds binds)
 347 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
 348
 349 addTickHsValBinds (ValBindsOut binds sigs) =
 350         liftM2 ValBindsOut
 351                 (mapM (\ (rec,binds') ->
 352                                 liftM2 (,)
 353                                         (return rec)
 354                                         (addTickLHsBinds binds'))
 355                         binds)
 356                 (return sigs)
 357
 358 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
 359         liftM2 IPBinds
 360                 (mapM (liftL addTickIPBind) ipbinds)
 361                 (addTickDictBinds dictbinds)
 362
 363 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 364 addTickIPBind (IPBind nm e) =
 365         liftM2 IPBind
 366                 (return nm)
 367                 (addTickLHsExpr e)
 368
 369 -- There is no location here, so we might need to use a context location??
 370 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
 371 addTickSyntaxExpr pos x = do
 372         L _ x' <- addTickLHsExpr (L pos x)
 373         return $ x'
 374 -- we do not walk into patterns.
 375 addTickLPat :: LPat Id -> TM (LPat Id)
 376 addTickLPat pat = return pat
 377
 378 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
 379 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 380         liftM4 HsCmdTop
 381                 (addTickLHsCmd cmd)
 382                 (return tys)
 383                 (return ty)
 384                 (return syntaxtable)
 385
 386 addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
 387 addTickLHsCmd x = addTickLHsExpr x
 388
 389 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
 390 addTickDictBinds x = addTickLHsBinds x
 391
 392 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 393 addTickHsRecordBinds pairs = mapM process pairs
 394     where
 395         process (ids,expr) =
 396                 liftM2 (,)
 397                         (return ids)
 398                         (addTickLHsExpr expr)
 399
 400 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
 401 addTickArithSeqInfo (From e1) =
 402         liftM From
 403                 (addTickLHsExpr e1)
 404 addTickArithSeqInfo (FromThen e1 e2) =
 405         liftM2 FromThen
 406                 (addTickLHsExpr e1)
 407                 (addTickLHsExpr e2)
 408 addTickArithSeqInfo (FromTo e1 e2) =
 409         liftM2 FromTo
 410                 (addTickLHsExpr e1)
 411                 (addTickLHsExpr e2)
 412 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
 413         liftM3 FromThenTo
 414                 (addTickLHsExpr e1)
 415                 (addTickLHsExpr e2)
 416                 (addTickLHsExpr e3)
 417 \end{code}
 418
 419 \begin{code}
 420 data TixFlags = TixFlags
 421
 422 data TickTransState = TT { modName     :: String
 423                          , declPath    :: [String]
 424                          , tickBoxCount:: Int
 425                          , mixEntries  :: [MixEntry]
 426                          }
 427         deriving Show
 428
 429 data TM a = TM { unTM :: TickTransState -> (a,TickTransState) }
 430
 431 instance Monad TM where
 432   return a = TM $ \ st -> (a,st)
 433   (TM m) >>= k = TM $ \ st -> case m st of
 434                                 (r1,st1) -> unTM (k r1) st1
 435
 436 --addTick :: LHsExpr Id -> TM (LHsExpr Id)
 437 --addTick e = TM $ \ uq -> (e,succ uq,[(uq,getLoc e)])
 438
 439 addPathEntry :: String -> TM a -> TM a
 440 addPathEntry nm (TM m) = TM $ \ st -> case m (st { declPath = declPath st ++ [nm] }) of
 441                                         (r,st') -> (r,st' { declPath = declPath st })
 442
 443 getPathEntry :: TM [String]
 444 getPathEntry = TM $ \ st -> (declPath st,st)
 445
 446 -- the tick application inherits the source position of its
 447 -- expression argument to support nested box allocations
 448 allocTickBox :: BoxLabel -> SrcSpan -> TM (LHsExpr Id -> LHsExpr Id)
 449 allocTickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
 450   let me = (hpcPos,boxLabel)
 451       c = tickBoxCount st
 452       mes = mixEntries st
 453   in ( \ (L pos e) -> L pos $ HsTick c (L pos e)
 454      , st {tickBoxCount=c+1,mixEntries=me:mes}
 455      )
 456 allocTickBox boxLabel e = return id
 457
 458 -- the tick application inherits the source position of its
 459 -- expression argument to support nested box allocations
 460 allocATickBox :: BoxLabel -> SrcSpan -> TM (Maybe Int)
 461 allocATickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
 462   let me = (hpcPos,boxLabel)
 463       c = tickBoxCount st
 464       mes = mixEntries st
 465   in ( Just c
 466      , st {tickBoxCount=c+1,mixEntries=me:mes}
 467      )
 468 allocATickBox boxLabel e = return Nothing
 469
 470 allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 471 allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
 472   let meT = (hpcPos,boxLabel True)
 473       meF = (hpcPos,boxLabel False)
 474       meE = (hpcPos,ExpBox)
 475       c = tickBoxCount st
 476       mes = mixEntries st
 477   in ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
 478         -- notice that F and T are reversed,
 479         -- because we are building the list in
 480         -- reverse...
 481      , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
 482      )
 483
 484 allocBinTickBox boxLabel e = return e
 485
 486 mkHpcPos :: SrcSpan -> Maybe HpcPos
 487 mkHpcPos pos
 488    | not (isGoodSrcSpan pos) = Nothing
 489    | start == end            = Nothing  -- no actual location
 490    | otherwise               = Just hpcPos
 491   where
 492    start = srcSpanStart pos
 493    end   = srcSpanEnd pos
 494    hpcPos = toHpcPos ( srcLocLine start
 495                      , srcLocCol start + 1
 496                      , srcLocLine end
 497                      , srcLocCol end
 498                      )
 499
 500 hpcSrcSpan = mkGeneralSrcSpan (FSLIT("Haskell Program Coverage internals"))
 501
 502 -- all newly allocated locations have an HPC tag on them, to help debuging
 503 hpcLoc :: e -> Located e
 504 hpcLoc = L hpcSrcSpan
 505 \end{code}
 506
 507
 508 \begin{code}
 509 ---------------------------------------------------------------
 510 -- Datatypes and file-access routines for the per-module (.mix)
 511 -- indexes used by Hpc.
 512 -- Colin Runciman and Andy Gill, June 2006
 513 ---------------------------------------------------------------
 514
 515 -- a module index records the attributes of each tick-box that has
 516 -- been introduced in that module, accessed by tick-number position
 517 -- in the list
 518
 519 data Mix = Mix
 520              FilePath           -- location of original file
 521              Integer            -- time (in seconds) of original file's last update, since 1970.
 522              Int                -- tab stop value
 523              [MixEntry]         -- entries
 524         deriving (Show,Read)
 525
 526 -- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
 527 -- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
 528 -- because if some other program also defined that instance, we will not be able to compile.
 529
 530 type MixEntry = (HpcPos, BoxLabel)
 531
 532 data BoxLabel = ExpBox
 533               | AltBox
 534               | TopLevelBox [String]
 535               | LocalBox [String]
 536            -- | UserBox (Maybe String)
 537               | GuardBinBox Bool
 538               | CondBinBox Bool
 539               | QualBinBox Bool
 540            -- | PreludeBinBox String Bool
 541            -- | UserBinBox (Maybe String) Bool
 542               deriving (Read, Show)
 543
 544 mixCreate :: String -> String -> Mix -> IO ()
 545 mixCreate dirName modName mix =
 546    writeFile (mixName dirName modName) (show mix)
 547
 548 readMix :: FilePath -> String -> IO Mix
 549 readMix dirName modName = do
 550    contents <- readFile (mixName dirName modName)
 551    return (read contents)
 552
 553 mixName :: FilePath -> String -> String
 554 mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
 555
 556 getModificationTime' :: FilePath -> IO Integer
 557 getModificationTime' file = do
 558   (TOD sec _) <- System.Directory.getModificationTime file
 559   return $ sec
 560
 561 data Tix = Tix [PixEntry]       -- The number of tickboxes in each module
 562                [TixEntry]       -- The tick boxes
 563         deriving (Read, Show,Eq)
 564
 565 type TixEntry = Integer
 566
 567 -- always read and write Tix from the current working directory.
 568
 569 readTix :: String -> IO (Maybe Tix)
 570 readTix pname =
 571   catch (do contents <- readFile $ tixName pname
 572             return $ Just $ read contents)
 573         (\ _ -> return $ Nothing)
 574
 575 writeTix :: String -> Tix -> IO ()
 576 writeTix pname tix =
 577   writeFile (tixName pname) (show tix)
 578
 579 tixName :: String -> String
 580 tixName name = name ++ ".tix"
 581
 582 -- a program index records module names and numbers of tick-boxes
 583 -- introduced in each module that has been transformed for coverage
 584
 585 data Pix = Pix [PixEntry] deriving (Read, Show)
 586
 587 type PixEntry = ( String        -- module name
 588                 , Int           -- number of boxes
 589                 )
 590
 591 pixUpdate :: FilePath -> String -> String -> Int -> IO ()
 592 pixUpdate dirName progName modName boxCount = do
 593    fileUpdate (pixName dirName progName) pixAssign (Pix [])
 594    where
 595    pixAssign :: Pix -> Pix
 596    pixAssign (Pix pes) =
 597      Pix ((modName,boxCount) : filter ((/=) modName . fst) pes)
 598
 599 readPix :: FilePath -> String -> IO Pix
 600 readPix dirName pname = do
 601   contents <- readFile (pixName dirName pname)
 602   return (read contents)
 603
 604 tickCount :: Pix -> Int
 605 tickCount (Pix mp) = sum $ map snd mp
 606
 607 pixName :: FilePath -> String -> String
 608 pixName dirName name = dirName ++ "/" ++ name ++ ".pix"
 609
 610 -- updating a value stored in a file via read and show
 611 fileUpdate :: (Read a, Show a) => String -> (a->a) -> a -> IO()
 612 fileUpdate fname update init =
 613    catch
 614      (do
 615         valueText <- readFile fname
 616         ( case finite valueText of
 617           True ->
 618             writeFile fname (show (update (read valueText))) ))
 619      (const (writeFile fname (show (update init))))
 620
 621 finite :: [a] -> Bool
 622 finite []     = True
 623 finite (x:xs) = finite xs
 624
 625 data HpcPos = P !Int !Int !Int !Int deriving (Eq)
 626
 627 fromHpcPos :: HpcPos -> (Int,Int,Int,Int)
 628 fromHpcPos (P l1 c1 l2 c2) = (l1,c1,l2,c2)
 629
 630 toHpcPos :: (Int,Int,Int,Int) -> HpcPos
 631 toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
 632
 633 instance Show HpcPos where
 634    show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
 635
 636 instance Read HpcPos where
 637   readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
 638       where
 639          (before,after)   = span (/= ',') pos
 640          (lhs,rhs)    = case span (/= '-') before of
 641                                (lhs,'-':rhs) -> (lhs,rhs)
 642                                (lhs,"")      -> (lhs,lhs)
 643          (l1,':':c1)      = span (/= ':') lhs
 644          (l2,':':c2)      = span (/= ':') rhs
 645
 646 \end{code}
 647