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