hpc-codecov-0.5.0.0: src/Trace/Hpc/Codecov/Report/Entry.hs
-- |
-- Module: Trace.Hpc.Codecov.Report.Entry
-- Copyright: (c) 2023 8c6794b6
-- License: BSD3
-- Maintainer: 8c6794b6 <8c6794b6@gmail.com>
--
-- Codes for converting tix and mix files to 'CoverageEntry'.
module Trace.Hpc.Codecov.Report.Entry
( Report(..)
, CoverageEntry(..)
, Format(..)
, LineHits
, Hit(..)
, FunctionHits
, BranchHits
, tixToCoverage
, readTixFile
) where
-- base
import Control.Applicative ((<|>))
import Control.Exception (ErrorCall, handle, throw,
throwIO)
import Control.Monad (when)
import Control.Monad.ST (ST)
import Data.Function (on)
import Data.List (foldl', intercalate)
import System.IO (hPutStrLn, stderr)
-- array
import Data.Array.Base (unsafeAt)
import Data.Array.IArray (assocs, listArray)
import Data.Array.MArray (newArray, readArray,
writeArray)
import Data.Array.ST (STArray, runSTArray)
import Data.Array.Unboxed (UArray)
-- containers
import qualified Data.IntMap as IntMap
-- directory
import System.Directory (doesFileExist)
-- filepath
import System.FilePath ((<.>), (</>))
-- hpc
import Trace.Hpc.Mix (BoxLabel (..), Mix (..),
MixEntry)
import Trace.Hpc.Tix (Tix (..), TixModule (..))
import Trace.Hpc.Util (fromHpcPos)
-- Internal
import Trace.Hpc.Codecov.Exception
import Trace.Hpc.Codecov.Parser
-- ------------------------------------------------------------------------
--
-- Types
--
-- ------------------------------------------------------------------------
-- | Data type to hold information for generating test coverage
-- report.
data Report = Report
{ reportTix :: FilePath
-- ^ Input tix file.
, reportMixDirs :: [FilePath]
-- ^ Directories containing mix files referred by the tix file.
, reportSrcDirs :: [FilePath]
-- ^ Directories containing source codes referred by the mix files.
, reportExcludes :: [String]
-- ^ Module name strings to exclude from coverage report.
, reportOutFile :: Maybe FilePath
-- ^ Output file to write report data, if given.
, reportVerbose :: Bool
-- ^ Flag for showing verbose message during report generation.
, reportFormat :: Format
-- ^ Format of the report output.
--
-- @since 0.4.0.0
} deriving (Eq, Show)
instance Semigroup Report where
(<>) = mappendReport
instance Monoid Report where
mempty = emptyReport
emptyReport :: Report
emptyReport = Report
{ reportTix = throw NoTarget
, reportMixDirs = []
, reportSrcDirs = []
, reportExcludes = []
, reportOutFile = Nothing
, reportVerbose = False
, reportFormat = Codecov
}
mappendReport :: Report -> Report -> Report
mappendReport r1 r2 =
let extend f g = (f `on` g) r1 r2
in Report { reportTix = reportTix r2
, reportMixDirs = extend (<>) reportMixDirs
, reportSrcDirs = extend (<>) reportSrcDirs
, reportExcludes = extend (<>) reportExcludes
, reportOutFile = extend (<|>) reportOutFile
, reportVerbose = extend (||) reportVerbose
, reportFormat = reportFormat r2
}
-- | Single file entry in coverage report.
--
data CoverageEntry =
CoverageEntry { ce_filename :: FilePath -- ^ Source code file name.
, ce_hits :: LineHits -- ^ Line hits of the file.
, ce_fns :: FunctionHits
-- ^ Function hits of the file.
--
-- @since 0.4.0.0
, ce_branches :: BranchHits
-- ^ Branch hits of the file.
--
-- @since 0.4.0.0
} deriving (Eq, Show)
-- | Pair of line number and hit tag.
type LineHits = [(Int, Hit)]
-- | Data type to represent coverage of source code line.
--
-- The 'Int' value in 'Partial' and 'Full' are the hit count.
data Hit
= Missed -- ^ The line is not covered at all.
| Partial Int -- ^ The line is partially covered.
| Full Int -- ^ The line is fully covered.
deriving (Eq, Show)
-- | Type synonym for tracking function enter count. Elements are
-- start line number, end line number, execution count, and function
-- name.
--
-- @since 0.4.0.0
type FunctionHits = [(Int, Int, Int, String)]
-- | Type synonym for tracking branch information. Elements are start
-- line number, branch block number, 'Bool' for the taken branch, and
-- execution count.
--
-- @since 0.4.0.0
type BranchHits = [(Int, Int, Bool, Int)]
-- | Data type for generated report format.
data Format
= Codecov
-- ^ Custom Codecov JSON format. See the
-- <https://docs.codecov.io/docs/codecov-custom-coverage-format Codecov documentation>
-- for detail.
--
-- @since 0.1.0.0
| Lcov
-- ^ LCOV tracefile format. See the
-- <https://ltp.sourceforge.net/coverage/lcov/geninfo.1.php geninfo manpage>
-- for detail.
--
-- @since 0.4.0.0
| Cobertura
-- ^ Cobertura XML file format. See the
-- <https://cobertura.github.io/cobertura/ Cobertura> website for detail.
--
-- @since 0.5.0.0
deriving (Eq, Show)
-- ------------------------------------------------------------------------
--
-- Tix to CoverageEntry
--
-- ------------------------------------------------------------------------
tixToCoverage :: Report -> Tix -> IO [CoverageEntry]
tixToCoverage rpt (Tix tms) =
mapM (tixModuleToCoverage rpt) (excludeModules rpt tms)
tixModuleToCoverage :: Report -> TixModule -> IO CoverageEntry
tixModuleToCoverage rpt tm@(TixModule name _hash count ixs) = do
say rpt ("Searching mix: " ++ name)
Mix path _ _ _ entries <- readMixFile (reportMixDirs rpt) tm
say rpt ("Found mix: " ++ path)
let Info _ min_line max_line hits fns pre_brs = makeInfo count ixs entries
lineHits = makeLineHits min_line max_line hits
path' <- ensureSrcPath rpt path
return (CoverageEntry { ce_filename = path'
, ce_hits = lineHits
, ce_fns = fns
, ce_branches = reBranch pre_brs })
-- | Exclude modules specified in given 'Report'.
excludeModules :: Report -> [TixModule] -> [TixModule]
excludeModules rpt = filter exclude
where
exclude (TixModule pkg_slash_name _ _ _) =
let modname = case break (== '/') pkg_slash_name of
(_, '/':name) -> name
(name, _) -> name
in notElem modname (reportExcludes rpt)
-- | Read tix file from file path, return a 'Tix' data or throw
-- a 'TixNotFound' exception.
readTixFile :: Report -> FilePath -> IO Tix
readTixFile rpt path = do
mb_tix <- {-# SCC "readTixFile.readTix'" #-} readTix' path
case mb_tix of
Nothing -> throwIO (TixNotFound path)
Just tix -> say rpt ("Found tix file: " ++ path) >> return tix
-- | Search mix file under given directories, return a 'Mix' data or
-- throw a 'MixNotFound' exception.
readMixFile :: [FilePath] -> TixModule -> IO Mix
readMixFile dirs tm@(TixModule name _h _c _i) = handle handler go
where
handler :: ErrorCall -> IO a
handler _ = throwIO (MixNotFound name dirs')
dirs' = map (</> (name <.> "mix")) dirs
go = {-# SCC "readMixFile.readMix'" #-} readMix' dirs (Right tm)
-- | Ensure the given source file exist, return the ensured 'FilePath'
-- or throw a 'SrcNotFound' exception.
ensureSrcPath :: Report -> FilePath -> IO FilePath
ensureSrcPath rpt path = go [] (reportSrcDirs rpt)
where
go acc [] = throwIO (SrcNotFound path acc)
go acc (dir:dirs) = do
let path' = dir </> path
exist <- doesFileExist path'
if exist
then say rpt ("Found source: " ++ path') >> return path'
else go (path':acc) dirs
-- | Arrange branch hit information.
--
-- LCOV tracefile seems like want to have a true branch before the
-- corresponding false branch, so arranging the order.
--
-- Also assigning sequential block numbers to the branch entries
-- starting with identical line number.
reBranch :: PreBranchHits -> BranchHits
reBranch = go mempty
where
go im0 ((lf,brf,nf) : (lt,brt,nt) : rest) =
let (mb_i, im1) = IntMap.insertLookupWithKey f lf 0 im0
f _key _new old = old + 1 :: Int
i = maybe 0 succ mb_i
in (lt,i,brt,nt) : (lf,i,brf,nf) : go im1 rest
go _ _ = []
-- | Print given message to 'stderr' when the verbose flag is 'True'.
say :: Report -> String -> IO ()
say rpt = when (reportVerbose rpt) . hPutStrLn stderr
-- | Internal type synonym to represent code line hit. Using 'Int' so
-- that unboxed arrays can use in its elements.
type Tick = Int
-- | Internal type synonym to represent line hit count.
type Count = Int
-- | Like 'BranchHits', but without branch block number.
type PreBranchHits = [(Int, Bool, Count)]
-- | Internal type used for accumulating mix entries.
data Info =
Info {-# UNPACK #-} !Int -- ^ Index count
{-# UNPACK #-} !Int -- ^ Min line number
{-# UNPACK #-} !Int -- ^ Max line number
[(Int, Tick, Count)] -- ^ Start line number, tick, and count.
FunctionHits -- ^ For tracking function.
PreBranchHits -- ^ For tracking branch.
-- | Make line hits from intermediate info.
makeLineHits :: Int -> Int -> [(Int, Tick, Count)] -> LineHits
makeLineHits min_line max_line hits = ticksToHits (assocs merged)
where
merged = runSTArray $ do
arr <- newArray (min_line, max_line) (ignored, 0)
mapM_ (updateOne arr) hits
return arr
updateOne :: STArray s Int (Tick, Count) -> (Int, Tick, Count) -> ST s ()
updateOne arr (i, hit, count) = do
(old_hit, old_count) <- readArray arr i
writeArray arr i (mergeEntry old_hit hit, max old_count count)
mergeEntry prev curr
| isMissed prev, isFull curr = partial
| isFull prev, isMissed curr = partial
| isPartial prev = prev
| otherwise = curr
-- | Convert array of ticks to list of hits.
ticksToHits :: [(Int, (Tick, Count))] -> LineHits
ticksToHits = foldr f []
where
f (i,(tck,n)) acc
| isIgnored tck = acc
| isMissed tck = (i, Missed) : acc
| isFull tck = (i, Full n) : acc
| otherwise = (i, Partial n) : acc
ignored, missed, partial, full :: Tick
ignored = -1
missed = 0
partial = 1
full = 2
isIgnored :: Tick -> Bool
isIgnored = (== ignored)
isMissed :: Tick -> Bool
isMissed = (== missed)
isPartial :: Tick -> Bool
isPartial = (== partial)
isFull :: Tick -> Bool
isFull = (== full)
notTicked, ticked :: Tick
notTicked = missed
ticked = full
-- See also: "utils/hpc/HpcMarkup.hs" in "ghc" git repository.
makeInfo :: Int -> [Integer] -> [MixEntry] -> Info
makeInfo size tixs = foldl' f z
where
z = Info 0 maxBound 0 [] [] []
f (Info i0 min_line max_line txs fns brs) (pos, boxLabel) =
let binBox =
case (isTicked i0, isTicked i1) of
(False, False) -> txs
(True, False) -> (sl, partial, numTicked i0) : txs
(False, True) -> (sl, partial, numTicked i1) : txs
(True, True) -> txs
tickBox =
let t | isTicked i0 = ticked
| otherwise = notTicked
in (sl, t, numTicked i0) : txs
tlBox ns = (sl, el, numTicked i0, intercalate "." ns) : fns
br bool = (sl, bool, numTicked i0)
(txs', fns', brs') =
case boxLabel of
ExpBox {} -> (tickBox, fns, brs)
TopLevelBox ns -> (tickBox, tlBox ns, brs)
LocalBox {} -> (tickBox, fns, brs)
BinBox _ True -> (binBox, fns, br True : brs)
BinBox _ False -> (txs, fns, br False : brs)
(sl, _, el, _) = fromHpcPos pos
i1 = i0 + 1
in Info i1 (min sl min_line) (max el max_line) txs' fns' brs'
-- Hope that the mix file does not contain out of bound index.
numTicked = unsafeAt arr_tix
isTicked n = numTicked n /= 0
arr_tix :: UArray Int Tick
arr_tix = listArray (0, size - 1) (map fromIntegral tixs)