hpc-codecov-0.5.0.0: src/Trace/Hpc/Codecov/Report/Emit.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- |
-- Module: Trace.Hpc.Codecov.Report.Emit
-- Copyright: (c) 2023 8c6794b6
-- License: BSD3
-- Maintainer: 8c6794b6 <8c6794b6@gmail.com>
--
-- Emit 'CoverageEntry' to other report format.
module Trace.Hpc.Codecov.Report.Emit
( buildCodecov
, buildLcov
, buildCobertura
) where
-- base
import Data.Char (isUpper)
import Data.List (foldl', intercalate,
intersperse)
import System.IO.Unsafe (unsafePerformIO)
#if !MIN_VERSION_bytestring(0,11,0)
import Text.Printf (printf)
#endif
-- bytestring
import Data.ByteString.Builder (Builder, char7, intDec,
string7, stringUtf8)
#if MIN_VERSION_bytestring(0,11,0)
import Data.ByteString.Builder.RealFloat (formatDouble,
standardDefaultPrecision)
#endif
-- containers
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
-- filepath
import System.FilePath (dropExtension,
splitDirectories,
takeDirectory)
-- time
import Data.Time.Clock.POSIX (getPOSIXTime)
-- Internal
import Trace.Hpc.Codecov.Report.Entry
-- ------------------------------------------------------------------------
-- Codecov
-- ------------------------------------------------------------------------
-- | Build simple Codecov JSON report from coverage entries.
buildCodecov :: [CoverageEntry] -> Builder
buildCodecov entries = contents
where
contents =
braced (key (string7 "coverage") <>
braced (listify (map report entries))) <>
char7 '\n'
report ce =
key (stringUtf8 (ce_filename ce)) <>
braced (listify (map hit (ce_hits ce)))
key x = dquote x <> char7 ':'
braced x = char7 '{' <> x <> char7 '}'
listify xs = mconcat (intersperse comma xs)
hit (n, tag) =
case tag of
Missed -> k <> char7 '0'
Partial {} -> k <> dquote (string7 "1/2")
Full i -> k <> intDec i
where
k = key (intDec n)
-- ------------------------------------------------------------------------
-- Lcov
-- ------------------------------------------------------------------------
-- | Build simple lcov tracefile from coverage entries.
buildLcov :: [CoverageEntry] -> Builder
buildLcov = mconcat . map buildLcovEntry
buildLcovEntry :: CoverageEntry -> Builder
buildLcovEntry e =
string7 "TN:" <> nl <>
string7 "SF:" <> stringUtf8 (ce_filename e) <> nl <>
fns_and_nl <>
string7 "FNF:" <> intDec fnf <> nl <>
string7 "FNH:" <> intDec fnh <> nl <>
brdas_and_nl <>
string7 "BRF:" <> intDec brf <> nl <>
string7 "BRH:" <> intDec brh <> nl <>
das_and_nl <>
string7 "LF:" <> intDec lf <> nl <>
string7 "LH:" <> intDec lh <> nl <>
string7 "end_of_record" <> nl
where
fold_hits f xs =
let (as, bs, nentry, nhit) = foldr f ([],[],0,0) xs
res = as <> bs
res_and_nl | null res = mempty
| otherwise = mconcat (intersperse nl res) <> nl
in (res_and_nl, nentry, nhit)
(fns_and_nl, fnf, fnh) = fold_hits ffn (ce_fns e)
ffn (sl, el, n, name) (fn_acc, fnda_acc, num_fns, num_hit_fns) =
( string7 "FN:" <> intDec sl <> comma <> intDec el <>
comma <> name' : fn_acc
, string7 "FNDA:" <> intDec n <> comma <> name' : fnda_acc
, num_fns + 1
, if n == 0 then num_hit_fns else num_hit_fns + 1 )
where
name' = stringUtf8 name
(brdas_and_nl, brf, brh) = fold_hits fbr (ce_branches e)
fbr (sl, blk, bool, n) (_, br, num_brs, num_hit_brs) =
( []
, string7 "BRDA:" <> intDec sl <> comma <>
intDec blk <> comma <>
char7 (if bool then '0' else '1') <> comma <>
intDec n : br
, num_brs + 1
, if n == 0 then num_hit_brs else num_hit_brs + 1 )
(das_and_nl, lf, lh) = fold_hits fda (ce_hits e)
fda (n, hit) (_, da, num_lines, num_hits) =
case hit of
Missed -> ([], da0 n:da, num_lines + 1, num_hits)
Partial i -> ([], dai n i:da, num_lines + 1, num_hits + 1)
Full i -> ([], dai n i:da, num_lines + 1, num_hits + 1)
da0 n = string7 "DA:" <> intDec n <> comma <> char7 '0'
dai n i = string7 "DA:" <> intDec n <> comma <> intDec i
nl = char7 '\n'
-- ------------------------------------------------------------------------
-- Cobertura
-- ------------------------------------------------------------------------
class HasRate c e where
numValid :: c e -> Int
numCovered :: c e -> Int
newtype Lines a = Lines {unLines :: a}
newtype Branches a = Branches {unBranches :: a}
buildRateOf :: HasRate c e => c e -> Builder
buildRateOf x = buildRate (numCovered x) (numValid x)
{-# INLINABLE buildRateOf #-}
buildRate :: Int -> Int -> Builder
buildRate n d =
if d == 0 then
string7 "0.0"
else
formatStandardDouble (fromIntegral n / fromIntegral d)
{-# INLINABLE buildRate #-}
data Acc = Acc
{ acc_valid_lines :: !Int
, acc_covered_lines :: !Int
, acc_valid_branches :: !Int
, acc_covered_branches :: !Int
}
accLinesAndBranches :: (HasRate Lines e, HasRate Branches e) => [e] -> Acc
accLinesAndBranches = foldl' f (Acc 0 0 0 0)
where
f acc e = acc
{ acc_valid_lines = acc_valid_lines acc + numValid (Lines e)
, acc_covered_lines = acc_covered_lines acc + numCovered (Lines e)
, acc_valid_branches = acc_valid_branches acc + numValid (Branches e)
, acc_covered_branches = acc_covered_branches acc + numCovered (Branches e)
}
data CoberturaPackage = CoberturaPackage
{ cp_name :: String
, cp_lines_valid :: !Int
, cp_lines_covered :: !Int
, cp_branch_valid :: !Int
, cp_branch_covered :: !Int
, cp_classes :: [CoberturaClass]
}
instance HasRate Lines CoberturaPackage where
numValid = cp_lines_valid . unLines
{-# INLINE numValid #-}
numCovered = cp_lines_covered . unLines
{-# INLINE numCovered #-}
instance HasRate Branches CoberturaPackage where
numValid = cp_branch_valid . unBranches
{-# INLINE numValid #-}
numCovered = cp_branch_covered . unBranches
{-# INLINE numCovered #-}
data CoberturaClass = CoberturaClass
{ cc_filename :: String
, cc_lines_valid :: !Int
, cc_lines_covered :: !Int
, cc_branch_valid :: !Int
, cc_branch_covered :: !Int
, cc_methods :: [CoberturaMethod]
, cc_lines :: [CoberturaLine]
}
instance HasRate Lines CoberturaClass where
numValid = cc_lines_valid . unLines
{-# INLINE numValid #-}
numCovered = cc_lines_covered . unLines
{-# INLINE numCovered #-}
instance HasRate Branches CoberturaClass where
numValid = cc_branch_valid . unBranches
{-# INLINE numValid #-}
numCovered = cc_branch_covered . unBranches
{-# INLINE numCovered #-}
data CoberturaMethod = CoberturaMethod
{ cm_line_num :: !Int
, cm_name :: String
}
data CoberturaLine = CoberturaLine
{ cl_line_num :: !Int
, cl_num_hits :: !Int
, cl_branch_hits :: Map.Map (Int, Bool) Int
}
-- | Build simple Cobertura XML report from coverage entries.
buildCobertura :: [CoverageEntry] -> Builder
buildCobertura es =
string7 "<?xml version=\"1.0\" ?>" <>
string7 "<!DOCTYPE coverage SYSTEM 'http://cobertura.sourceforge.nex/xml/coverage-0.4.dtd'>" <>
xmlTagWith "coverage" coverage_attrs
(xmlTag "sources" (xmlTag "source" (char7 '.')) <>
xmlTag "packages" (mconcat (map buildCoberturaPackage pkgs))) <>
char7 '\n'
where
coverage_attrs =
[("branch-rate", buildRate bc bv)
,("branches-covered", intDec bc)
,("branches-valid", intDec bv)
,("complexity", char7 '0')
,("line-rate", buildRate lc lv)
,("lines-covered", intDec lc)
,("lines-valid", intDec lv)
,("timestamp", intDec $ fromInteger unsafeGetTimestamp)
,("version", string7 "2.0.3")]
pkgs = toCoberturaPackages es
Acc lv lc bv bc = accLinesAndBranches pkgs
-- XXX: Not sure whether this is the preferred timestamp format.
unsafeGetTimestamp :: Integer
unsafeGetTimestamp = round (unsafePerformIO getPOSIXTime)
{-# NOINLINE unsafeGetTimestamp #-}
buildCoberturaPackage :: CoberturaPackage -> Builder
buildCoberturaPackage cp =
xmlTagWith "package" package_attrs
(xmlTag "classes"
(mconcat (map buildCoberturaClass (cp_classes cp))))
where
package_attrs =
[("name", stringUtf8 $ cp_name cp)
,("line-rate", buildRateOf (Lines cp))
,("branch-rate", buildRateOf (Branches cp))
,("complexity", char7 '0')]
buildCoberturaClass :: CoberturaClass -> Builder
buildCoberturaClass cc =
xmlTagWith "class" class_attrs
(xmlTag "methods" (mconcat (map method (cc_methods cc))) <>
xmlTag "lines" (mconcat (map line (cc_lines cc))))
where
class_attrs =
[("branch-rate", buildRateOf (Branches cc))
,("complexity", char7 '0')
,("filename", stringUtf8 $ cc_filename cc)
,("line-rate", buildRateOf (Lines cc))
,("name", stringUtf8 $ toModuleName (cc_filename cc))]
method cm =
xmlTagWith "method" method_attrs
(xmlTag "lines" (line_tag line_attrs))
where
method_attrs =
[("name", stringUtf8 $ xmlEscape (cm_name cm))
,("signature", mempty)
,("line-rate", string7 "0.0")
,("branch-rate", string7 "0.0")]
line_attrs =
[("hits", char7 '0')
,("number", intDec (cm_line_num cm))
,("branch", string7 "false")]
line cl = line_tag line_attrs
where
is_branch = not (null (cl_branch_hits cl))
line_attrs =
[("branch", string7 $ if is_branch then "true" else "false")
,("hits", intDec (cl_num_hits cl))
,("number", intDec (cl_line_num cl)) ] <>
[("condition-coverage", buildConditionCoverage (cl_branch_hits cl))
| is_branch ]
line_tag attrs =
string7 "<line" <> mconcat (map xmlAttr attrs) <> string7 "/>"
buildConditionCoverage :: Map.Map a Int -> Builder
buildConditionCoverage m = fmt
where
fmt = percentage <> char7 ' ' <> char7 '(' <> fraction <> char7 ')'
percentage = intDec (round (100 * rate)) <> char7 '%'
fraction = intDec covered <> char7 '/' <> intDec valid
rate = fromIntegral covered / fromIntegral valid :: Double
(covered, valid) = foldl' f (0, 0) m
f (c, v) num_hits = (if 0 < num_hits then c + 1 else c, v + 1)
toCoberturaPackages :: [CoverageEntry] -> [CoberturaPackage]
toCoberturaPackages =
Map.foldrWithKey' go [] . Map.fromListWith (<>) . map pair_with_pkgname
where
pair_with_pkgname ce =
(toCoberturaPackageName (ce_filename ce), [toCoberturaClass ce])
go pkg_name ces acc =
let Acc lv lc bv bc = accLinesAndBranches ces
in CoberturaPackage { cp_name = pkg_name
, cp_lines_valid = lv
, cp_lines_covered = lc
, cp_branch_valid = bv
, cp_branch_covered = bc
, cp_classes = ces
} : acc
toCoberturaClass :: CoverageEntry -> CoberturaClass
toCoberturaClass ce = CoberturaClass
{ cc_filename = ce_filename ce
, cc_lines_valid = lv
, cc_lines_covered = lc
, cc_branch_valid = bv
, cc_branch_covered = bc
, cc_methods = methods
, cc_lines = IntMap.elems im1
}
where
(lv, lc, im0) = foldl' acc_line (0, 0, mempty) (ce_hits ce)
(bv, bc, im1) = foldl' acc_branch (0, 0, im0) (ce_branches ce)
acc_line (lv0, lc0, im) (n, hit) =
case hit of
Missed -> (lv0 + 1, lc0, IntMap.insert n (make_line n 0) im)
Partial i -> (lv0 + 1, lc0 + 1, IntMap.insert n (make_line n i) im)
Full i -> (lv0 + 1, lc0 + 1, IntMap.insert n (make_line n i) im)
make_line n i = CoberturaLine n i mempty
make_branch n i bn bool = CoberturaLine n i (Map.singleton (bn,bool) i)
merge_brs new_cl old_cl = CoberturaLine
{ cl_line_num = cl_line_num old_cl
, cl_num_hits = max (cl_num_hits old_cl) (cl_num_hits new_cl)
, cl_branch_hits =
Map.unionWith (+) (cl_branch_hits old_cl) (cl_branch_hits new_cl)
}
acc_branch (bv0, bc0, im) (n, bn, bool, count) =
let im' = IntMap.insertWith merge_brs n (make_branch n count bn bool) im
in (bv0 + 1, if count == 0 then bc0 else bc0 + 1, im')
methods = map to_method (ce_fns ce)
to_method (sl,_,_,name) = CoberturaMethod sl name
toCoberturaPackageName :: FilePath -> String
toCoberturaPackageName = intercalate "." . splitDirectories . takeDirectory
toModuleName :: FilePath -> String
toModuleName path = intercalate "." paths'
where
paths' = [p | p@(c:_) <- splitDirectories (dropExtension path), isUpper c ]
xmlTag :: String -> Builder -> Builder
xmlTag name = xmlTagWith name []
xmlTagWith :: String -> [(String, Builder)] -> Builder -> Builder
xmlTagWith name attrs body =
char7 '<' <> string7 name <> attrs' <> char7 '>' <>
body <>
string7 "</" <> string7 name <> char7 '>'
where
attrs' =
if null attrs then mempty else mconcat (map xmlAttr attrs)
xmlAttr :: (String, Builder) -> Builder
xmlAttr (name, val) = char7 ' ' <> string7 name <> char7 '=' <> dquote val
xmlEscape :: String -> String
xmlEscape = go
where
go [] = []
go (c:rest) = case c of
'>' -> ">" <> go rest
'<' -> "<" <> go rest
'"' -> """ <> go rest
'&' -> "&" <> go rest
_ -> c:go rest
-- ------------------------------------------------------------------------
-- Auxiliary
-- ------------------------------------------------------------------------
dquote :: Builder -> Builder
dquote x = char7 '"' <> x <> char7 '"'
{-# INLINABLE dquote #-}
comma :: Builder
comma = char7 ','
{-# INLINABLE comma #-}
formatStandardDouble :: Double -> Builder
#if MIN_VERSION_bytestring(0,11,0)
formatStandardDouble = formatDouble standardDefaultPrecision
#else
formatStandardDouble = string7 . printf "%f"
#endif
{-# INLINABLE formatStandardDouble #-}