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