diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Revision history for hpc-codecov +## 0.4.0.0 -- 2023-07 + +Add "--format" option to select the output report format. Add LCOV +tracefile format for generated report. + +Modify the generated report to preserve line hit counts. + +Add simple ``ByteString`` based parsers for reading ``.mix`` and +``.tix`` files to improve performance. + +Remove ``Paths_hpc_codecov`` from exported modules. + ## 0.3.0.0 -- 2021-04-02 Modify command-line argument to support TOOL:TEST_SUITE style target, diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2020, 8c6794b6 +Copyright (c) 2022, 8c6794b6 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,18 +1,17 @@ # hpc-codecov [![Hackage](https://img.shields.io/hackage/v/hpc-codecov)](https://hackage.haskell.org/package/hpc-codecov) [![Stackage](https://www.stackage.org/package/hpc-codecov/badge/lts)](https://www.stackage.org/lts/package/hpc-codecov) [![codecov](https://codecov.io/gh/8c6794b6/hpc-codecov/branch/master/graph/badge.svg)](https://codecov.io/gh/8c6794b6/hpc-codecov) -[![Travis](http://img.shields.io/travis/8c6794b6/codecov-haskell/master.svg?logo=travis)](https://travis-ci.com/8c6794b6/hpc-codecov) [![CircleCI](https://img.shields.io/circleci/build/gh/8c6794b6/hpc-codecov/master?logo=circleci)](https://circleci.com/gh/8c6794b6/hpc-codecov) [![AppVeyor](https://ci.appveyor.com/api/projects/status/dijqtsoqgc26oghj?svg=true)](https://ci.appveyor.com/project/8c6794b6/hpc-codecov) -[![GitHub](https://img.shields.io/github/workflow/status/8c6794b6/hpc-codecov/ci?logo=github)](https://github.com/8c6794b6/hpc-codecov/actions/workflows/ci.yml) +[![GitHub](https://img.shields.io/github/actions/workflow/status/8c6794b6/hpc-codecov/ci.yml?branch=master&logo=github)](https://github.com/8c6794b6/hpc-codecov/actions/workflows/ci.yml) The ``hpc-codecov`` package contains an executable and library codes -for generating [Codecov](https://codecov.io) JSON coverage report from -``.tix`` and ``.mix`` files made with +for generating [Codecov](https://codecov.io) JSON coverage report or +[LCOV](https://github.com/linux-test-project/lcov) tracefile report +from ``.tix`` and ``.mix`` files made with [hpc](https://hackage.haskell.org/package/hpc). The generated report is ready to be uploaded to Codecov with other tools such as [Codecov -Bash -uploader](https://docs.codecov.io/docs/about-the-codecov-bash-uploader). +uploader](https://docs.codecov.com/docs/codecov-uploader). The ``hpc-codecov`` executable can search ``.tix`` and ``mix`` files under the directories made by the @@ -148,7 +147,17 @@ $ hpc-codecov stack:all -o codecov.json ``` +### Project using stack, with multiple packages, generate LCOV tracefile +Search under directory made by ``stack`` for combined report of +multiple cabal packages, and write output report in LCOV tracefile +format to ``lcov.info``: + +```consle +$ hpc-codecov stack:all -f lcov -o lcov.info +``` + + Low-level examples ------------------ @@ -174,7 +183,7 @@ ``.mix`` files: ```console -$ proj=hpc-codecov-0.3.0.0 +$ proj=hpc-codecov-0.4.0.0 $ tix=$(find ./dist-newstyle -name $proj.tix) $ mix=$(find ./dist-newstyle -name vanilla -print -quit)/mix/$proj $ hpc-codecov --mix=$mix --exclude=Paths_hpc_codecov --out=codecov.json $tix @@ -198,14 +207,14 @@ "63": 1, ``` -Send the resulting JSON report file to Codecov with the [bash -uploader](https://github.com/codecov/codecov-bash/). The file name +Send the resulting JSON report file to Codecov with the [Codecov +uploader](https://github.com/codecov/uploader). The file name ``codecov.json`` is listed in the uploader script as one of the file name patterns to upload, no need to specify the report filename explicitly: ```console -$ bash <(curl -s https://codecov.io/bash) +$ codecov -t ${CODECOV_TOKEN} ``` According to the Codecov @@ -214,7 +223,8 @@ [CircleCI](https://circleci.com/), [Azure](https://azure.microsoft.com/en-us/services/devops/pipelines), and [GitHub Actions](https://github.com/features/actions) for public -projects without the Codecov token. +projects without the Codecov token (i.e., without the `-t +${CODECOV_TOKEN}` option). ### With stack @@ -236,12 +246,6 @@ $ tix=$(find $hpcroot -name 'test-main.tix') $ mix=$(stack path --dist-dir)/hpc $ hpc-codecov --mix=$mix --exclude=Paths_hpc_codecov -o codecov.json $tix -``` - -Then send the resulting report file: - -```console -$ bash <(curl -s https://codecov.io/bash) ``` diff --git a/hpc-codecov.cabal b/hpc-codecov.cabal --- a/hpc-codecov.cabal +++ b/hpc-codecov.cabal @@ -1,20 +1,21 @@ cabal-version: 2.0 name: hpc-codecov -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Generate codecov report from hpc data license: BSD3 license-file: LICENSE author: 8c6794b6 maintainer: 8c6794b6@gmail.com homepage: https://github.com/8c6794b6/hpc-codecov#readme -copyright: (c) 2020 8c6794b6 +copyright: (c) 2022 8c6794b6 category: Test, Data build-type: Simple description: The hpc-codecov package contains an executable and library codes for - generating JSON coverage report from - @.tix@ and @.mix@ files made with + generating JSON coverage report or + tracefile report + from @.tix@ and @.mix@ files made with . See the for more info. @@ -42,24 +43,30 @@ , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 - , GHC == 8.10.1 - , GHC == 9.0.1 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.4 + , GHC == 9.4.2 + , GHC == 9.6.2 library hs-source-dirs: src exposed-modules: Trace.Hpc.Codecov.Exception Trace.Hpc.Codecov.Discover Trace.Hpc.Codecov.Main + Trace.Hpc.Codecov.Parser Trace.Hpc.Codecov.Report - Paths_hpc_codecov other-modules: Trace.Hpc.Codecov.Options + Paths_hpc_codecov autogen-modules: Paths_hpc_codecov build-depends: base >= 4.10 && < 5 , array >= 0.1 && < 0.6 , bytestring >= 0.10 && < 0.12 + , containers >= 0.6 && < 0.8 , directory >= 1.3.0 && < 1.4.0 , filepath >= 1.4.1 && < 1.5 , hpc >= 0.6 && < 0.7 + , time >= 1.8 && < 1.13 default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Trace/Hpc/Codecov/Discover.hs b/src/Trace/Hpc/Codecov/Discover.hs --- a/src/Trace/Hpc/Codecov/Discover.hs +++ b/src/Trace/Hpc/Codecov/Discover.hs @@ -49,7 +49,7 @@ -- ^ Tool used to build Haskell cabal package. , da_testsuite :: String -- ^ Test suite name to search for @.tix@ file. - , da_rootdir :: FilePath + , da_rootdir :: FilePath -- ^ The project root directory. , da_builddir :: Maybe String -- ^ Name of the temporary build directory made by the build tool. diff --git a/src/Trace/Hpc/Codecov/Exception.hs b/src/Trace/Hpc/Codecov/Exception.hs --- a/src/Trace/Hpc/Codecov/Exception.hs +++ b/src/Trace/Hpc/Codecov/Exception.hs @@ -1,6 +1,6 @@ -- | -- Module: Trace.Hpc.Codecov.Exception --- Copyright: (c) 2020 8c6794b6 +-- Copyright: (c) 2022 8c6794b6 -- License: BSD3 -- Maintainer: 8c6794b6 <8c6794b6@gmail.com> -- @@ -47,6 +47,8 @@ -- file. | InvalidBuildTool String -- ^ Invalid build tool. + | InvalidFormat String + -- ^ Invalid report format. | TestSuiteNotFound String -- ^ Test suite was given, but not found. | InvalidArgs [String] @@ -65,6 +67,7 @@ MixNotFound mix locs -> searchedLocations "mix" mix locs SrcNotFound src locs -> searchedLocations "src" src locs InvalidBuildTool tool-> "invalid build tool: `" ++ tool ++ "'\n" + InvalidFormat fmt -> "invalid format: `" ++ fmt ++ "'\n" TestSuiteNotFound name -> "cannot find tix for test suite: " ++ show name ++ "\n" InvalidArgs msgs -> diff --git a/src/Trace/Hpc/Codecov/Main.hs b/src/Trace/Hpc/Codecov/Main.hs --- a/src/Trace/Hpc/Codecov/Main.hs +++ b/src/Trace/Hpc/Codecov/Main.hs @@ -1,6 +1,6 @@ -- | -- Module: Trace.Hpc.Codecov.Main --- Copyright: (c) 2020 8c6794b6 +-- Copyright: (c) 2022 8c6794b6 -- License: BSD3 -- Maintainer: 8c6794b6 <8c6794b6@gmail.com> -- diff --git a/src/Trace/Hpc/Codecov/Options.hs b/src/Trace/Hpc/Codecov/Options.hs --- a/src/Trace/Hpc/Codecov/Options.hs +++ b/src/Trace/Hpc/Codecov/Options.hs @@ -1,7 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module: Trace.Hpc.Codecov.Options --- Copyright: (c) 2020 8c6794b6 +-- Copyright: (c) 2022 8c6794b6 -- License: BSD3 -- Maintainer: 8c6794b6 <8c6794b6@gmail.com> -- @@ -56,11 +56,14 @@ , optOutFile :: Maybe FilePath -- ^ Output file to write JSON report, if given. + , optFormat :: String + -- ^ Format of generated report. + , optVerbose :: Bool -- ^ Flag for showing verbose message during coverage report -- generation. - , optRootDir :: FilePath + , optRootDir :: FilePath -- ^ Project root directory for the build tool. , optBuildDir :: Maybe FilePath -- ^ Name of the build directory used by the build tool @@ -83,6 +86,7 @@ , optSrcDirs = [] , optExcludes = [] , optOutFile = Nothing + , optFormat = "codecov" , optVerbose = False , optRootDir = "" , optBuildDir = Nothing @@ -141,6 +145,13 @@ "Basename of directory to skip while\n\ \searching data for TOOL, can repeat" + , Option ['f'] ["format"] + (ReqArg (\s o -> o {optFormat = s}) + "FMT") + "Format of generated report\n\ + \'codecov' or 'lcov'\n\ + \(default: codecov)" + , Option ['v'] ["verbose"] (NoArg (\o -> o {optVerbose = True})) "Show verbose output" @@ -202,6 +213,12 @@ (tool, ':':_) -> throwIO $ InvalidBuildTool tool _ -> pure $ TixFile str +parseFormat :: String -> IO Format +parseFormat fmt = case fmt of + "codecov" -> pure Codecov + "lcov" -> pure Lcov + _ -> throwIO $ InvalidFormat fmt + uncommas :: String -> [String] uncommas = go where @@ -221,9 +238,11 @@ } tix = optTix opt verbose = optVerbose opt + format <- parseFormat (optFormat opt) target <- parseTarget tix case target of - TixFile path -> pure (rpt1 {reportTix = path}) + TixFile path -> pure (rpt1 {reportTix = path + ,reportFormat = format}) TestSuite tool name -> do rpt2 <- discover DiscoverArgs { da_tool = tool @@ -233,7 +252,7 @@ , da_skipdirs = optSkipDirs opt , da_verbose = verbose } - pure $ rpt1 `mappend` rpt2 + pure $ rpt1 `mappend` rpt2 {reportFormat = format} -- | Print help messages. printHelp :: IO () diff --git a/src/Trace/Hpc/Codecov/Parser.hs b/src/Trace/Hpc/Codecov/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Codecov/Parser.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +-- | +-- Module: Trace.Hpc.Codecov.Parser +-- Copyright: (c) 2023 8c6794b6 +-- License: BSD3 +-- Maintainer: 8c6794b6 <8c6794b6@gmail.com> +-- +-- Simple bytestring parser for reading @.mix@ and @.tix@ files. +-- +-- @since 0.4.0.0 + +module Trace.Hpc.Codecov.Parser + ( readTix' + , readMix' + ) where + +-- base +import Control.Applicative (Alternative (..)) +import Data.Functor (($>)) +import Prelude hiding (takeWhile) + +-- bytestring +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS + +-- filepath +import System.FilePath ((<.>), ()) + +-- hpc +import Trace.Hpc.Mix (BoxLabel (..), + CondBox (..), Mix (..), + MixEntry) +import Trace.Hpc.Tix (Tix (..), TixModule (..), + tixModuleName) +import Trace.Hpc.Util (HpcHash (..), HpcPos, + catchIO, toHpcPos) + +-- time +import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) +import Data.Time.Clock (UTCTime (..)) + + +-- ------------------------------------------------------------------------ +-- Exported +-- ------------------------------------------------------------------------ + +-- | Read a @.tix@ File. +-- +-- This function is similar to 'Trace.Hpc.Tix.readTix', but internally +-- uses 'ByteString' to improve performance. +readTix' :: FilePath -> IO (Maybe Tix) +readTix' path = + (runMaybeP parseTix <$> BS.readFile path) `catchIO` const (pure Nothing) + +-- | Read a @.mix@ file. +-- +-- This function is similar to 'Trace.Hpc.Mix.readMix', but internally +-- uses 'ByteString' to improve performance. +-- +-- __NOTE__: At the moment, the 'UTCTime' field in the parsed 'Mix' is +-- constantly filled with dummy value, to avoid parsing date time. +readMix' + :: [String] -- ^ Dir names + -> Either String TixModule -- ^ module wanted + -> IO Mix +readMix' dirs et_tm = go dirs + where + mixname = either id tixModuleName et_tm <.> "mix" + handler _ = pure (Left "err ...") + parse path = runEitherP parseMix <$> BS.readFile path + go [] = error "Cannot find mix file" + go (d:ds) = do + et_mix <- parse (d mixname) `catchIO` handler + case et_mix of + Right mix -> pure mix + Left _err -> go ds + + +-- ------------------------------------------------------------------------ +-- The parser +-- ------------------------------------------------------------------------ + +newtype P a = + P {runP :: forall r. (String -> r) -- On error + -> (a -> ByteString -> r) -- On success + -> ByteString -- Input to consume + -> r} + +instance Functor P where + fmap f p = P (\err ok -> runP p err (ok . f)) + {-# INLINE fmap #-} + +instance Applicative P where + pure x = P (\_ ok -> ok x) + {-# INLINE pure #-} + + pf <*> pa = P (\err ok -> runP pf err (\f -> runP (fmap f pa) err ok)) + {-# INLINE (<*>) #-} + +instance Monad P where + m >>= k = P (\err ok -> runP m err (\x -> runP (k x) err ok)) + {-# INLINE (>>=) #-} + +instance Alternative P where + empty = P (\err _ _ -> err "Alternative.empty") + {-# INLINE empty #-} + + p1 <|> p2 = P (\err go bs -> runP p1 (\_ -> runP p2 err go bs) go bs) + {-# INLINE (<|>) #-} + +runEitherP :: P a -> ByteString -> Either String a +runEitherP p = runP p Left (\a _ -> Right a) + +runMaybeP :: P a -> ByteString -> Maybe a +runMaybeP p = runP p (const Nothing) (\a _ -> Just a) + +char :: Char -> P () +char c = + P (\err ok bs -> + case BS.uncons bs of + Just (c', bs') | c == c' -> ok () bs' + _ -> err ("char: failed to get " <> show c)) +{-# INLINABLE char #-} + +bytes :: ByteString -> P () +bytes target = + P (\err ok bs -> + case BS.splitAt (BS.length target) bs of + (pre, post) | pre == target -> ok () post + _ -> err ("bytes: failed to parse `" <> show target <> "'")) +{-# INLINABLE bytes #-} + +int :: P Int +int = + P (\err ok bs -> + case BS.readInt bs of + Just (n, bs') -> ok n bs' + _ -> err "int: failed") +{-# INLINABLE int #-} + +integer :: P Integer +integer = fmap fromIntegral int +{-# INLINEABLE integer #-} + +spaces :: P () +spaces = P (\_ ok bs -> ok () (BS.dropSpace bs)) +{-# INLINABLE spaces #-} + +takeWhile :: (Char -> Bool) -> P ByteString +takeWhile test = + P (\_ ok bs -> case BS.span test bs of (pre, post) -> ok pre post) +{-# INLINABLE takeWhile #-} + +sepBy :: Alternative f => f a -> f s -> f [a] +sepBy a s = sepBy1 a s <|> pure [] +{-# INLINEABLE sepBy #-} + +sepBy1 :: Alternative f => f a -> f s -> f [a] +sepBy1 a s = go + where + go = (:) <$> a <*> ((s *> go) <|> pure []) +{-# INLINABLE sepBy1 #-} + +doubleQuoted :: P a -> P a +doubleQuoted p = char '"' *> p <* char '"' +{-# INLINEABLE doubleQuoted #-} + +bracketed :: P a -> P a +bracketed p = char '[' *> p <* char ']' +{-# INLINABLE bracketed #-} + +parenthesized :: P a -> P a +parenthesized p = char '(' *> p <* char ')' +{-# INLINABLE parenthesized #-} + +comma :: P () +comma = char ',' +{-# INLINABLE comma #-} + +bool :: P Bool +bool = true <|> false + where + true = bytes "True" $> True + false = bytes "False" $> False +{-# INLINABLE bool #-} + +string :: P String +string = BS.unpack <$> doubleQuoted (takeWhile (/= '"')) +{-# INLINABLE string #-} + + +-- ------------------------------------------------------------------------ +-- Tix parser +-- ------------------------------------------------------------------------ + +parseTix :: P Tix +parseTix = do + bytes "Tix" *> spaces + tix_modules <- bracketed (sepBy tixModule comma) + pure (Tix tix_modules) + +tixModule :: P TixModule +tixModule = do + spaces *> bytes "TixModule" *> spaces + name <- string <* spaces + hash <- fmap toHash int <* spaces + size <- int <* spaces + ticks <- bracketed (sepBy integer comma) + pure (TixModule name hash size ticks) + + +-- ------------------------------------------------------------------------ +-- Mix parser +-- ------------------------------------------------------------------------ + +parseMix :: P Mix +parseMix = do + bytes "Mix" *> spaces + path <- string <* spaces + _year <- takeWhile (/= ' ') <* spaces + _time <- takeWhile (/= ' ') <* spaces + _zone <- takeWhile (/= ' ') <* spaces + hash <- fmap toHash int <* spaces + tabstop <- int <* spaces + let dummy_date = UTCTime (fromOrdinalDate 1900 1) 0 + Mix path dummy_date hash tabstop <$> mixEntries + +mixEntries :: P [MixEntry] +mixEntries = bracketed (sepBy mixEntry comma) +{-# INLINABLE mixEntries #-} + +mixEntry :: P MixEntry +mixEntry = parenthesized $ do + pos <- hpcPos + comma + box <- boxLabel + pure (pos, box) +{-# INLINABLE mixEntry #-} + +hpcPos :: P HpcPos +hpcPos = do + sl <- int + char ':' + sc <- int + char '-' + el <- int + char ':' + ec <- int + pure (toHpcPos (sl, sc, el, ec)) +{-# INLINABLE hpcPos #-} + +boxLabel :: P BoxLabel +boxLabel = expBox <|> topLevelBox <|> localBox <|> binBox + where + expBox = bytes "ExpBox" *> spaces *> fmap ExpBox bool + topLevelBox = bytes "TopLevelBox" *> spaces *> fmap TopLevelBox names + localBox = bytes "LocalBox" *> spaces *> fmap LocalBox names + binBox = bytes "BinBox" *> spaces *> + (BinBox <$> (condBox <* spaces) <*> bool) +{-# INLINABLE boxLabel #-} + +names :: P [String] +names = bracketed (sepBy string comma) +{-# INLINABLE names #-} + +condBox :: P CondBox +condBox = guard <|> cond <|> qual + where + guard = bytes "GuardBinBox" $> GuardBinBox + cond = bytes "CondBinBox" $> CondBinBox + qual = bytes "QualBinBox" $> QualBinBox +{-# INLINABLE condBox #-} diff --git a/src/Trace/Hpc/Codecov/Report.hs b/src/Trace/Hpc/Codecov/Report.hs --- a/src/Trace/Hpc/Codecov/Report.hs +++ b/src/Trace/Hpc/Codecov/Report.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} -- | -- Module: Trace.Hpc.Codecov.Report --- Copyright: (c) 2020 8c6794b6 +-- Copyright: (c) 2022 8c6794b6 -- License: BSD3 -- Maintainer: 8c6794b6 <8c6794b6@gmail.com> -- @@ -11,13 +11,16 @@ ( -- * Types Report(..) , CoverageEntry(..) + , Format(..) , LineHits , Hit(..) + , FunctionHits + , BranchHits -- * Functions , genReport , genCoverageEntries - , emitCoverageJSON + , emitCoverage ) where -- base @@ -25,7 +28,7 @@ import Control.Monad (mplus, when) import Control.Monad.ST (ST) import Data.Function (on) -import Data.List (foldl', intersperse) +import Data.List (foldl', intercalate, intersperse) import System.IO (IOMode (..), hPutStrLn, stderr, stdout, withFile) #if !MIN_VERSION_base(4,11,0) @@ -34,15 +37,18 @@ -- array import Data.Array.Base (unsafeAt) -import Data.Array.IArray (bounds, listArray, range, (!)) +import Data.Array.IArray (assocs, listArray) import Data.Array.MArray (newArray, readArray, writeArray) -import Data.Array.ST (STUArray, runSTUArray) +import Data.Array.ST (STArray, runSTArray) import Data.Array.Unboxed (UArray) -- bytestring import Data.ByteString.Builder (Builder, char7, hPutBuilder, intDec, string7, stringUtf8) +-- containers +import Data.IntMap (insertLookupWithKey) + -- directory import System.Directory (doesFileExist) @@ -50,13 +56,13 @@ import System.FilePath ((<.>), ()) -- hpc -import Trace.Hpc.Mix (BoxLabel (..), Mix (..), MixEntry, - readMix) -import Trace.Hpc.Tix (Tix (..), TixModule (..), readTix) -import Trace.Hpc.Util (HpcPos, fromHpcPos) +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 -- ------------------------------------------------------------------------ @@ -77,9 +83,13 @@ , reportExcludes :: [String] -- ^ Module name strings to exclude from coverage report. , reportOutFile :: Maybe FilePath - -- ^ Output file to write JSON report, if given. + -- ^ 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) #if MIN_VERSION_base(4,11,0) @@ -89,7 +99,9 @@ instance Monoid Report where mempty = emptyReport +#if !MIN_VERSION_base(4,16,0) mappend = mappendReport +#endif emptyReport :: Report emptyReport = Report @@ -99,64 +111,110 @@ , reportExcludes = [] , reportOutFile = Nothing , reportVerbose = False + , reportFormat = Codecov } mappendReport :: Report -> Report -> Report mappendReport r1 r2 = - let extend f = ((<>) `on` f) 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 = (mplus `on` reportOutFile) r1 r2 - , reportVerbose = ((||) `on` reportVerbose) r1 r2 + , reportMixDirs = extend (<>) reportMixDirs + , reportSrcDirs = extend (<>) reportSrcDirs + , reportExcludes = extend (<>) reportExcludes + , reportOutFile = extend mplus reportOutFile + , reportVerbose = extend (||) reportVerbose + , reportFormat = reportFormat r2 } -- | Single file entry in coverage report. -- --- See the --- --- for detail. 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 -- ^ The line is partially covered. - | Full -- ^ The line is fully covered. + | 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 + -- + -- for detail. + -- + -- @since 0.1.0.0 + | Lcov + -- ^ LCOV tracefile format. See the + -- + -- for detail. + -- + -- @since 0.4.0.0 + deriving (Eq, Show) + -- | Generate report data from options. genReport :: Report -> IO () -genReport rpt = - do entries <- genCoverageEntries rpt - let mb_out = reportOutFile rpt - oname = maybe "stdout" show mb_out - say rpt ("Writing JSON report to " ++ oname) - emitCoverageJSON mb_out entries - say rpt "Done" +genReport rpt = do + entries <- genCoverageEntries rpt + let mb_out = reportOutFile rpt + oname = maybe "stdout" show mb_out + say rpt ("Writing report to " ++ oname) + emitCoverage (reportFormat rpt) mb_out entries + say rpt "Done" -- | Generate test coverage entries. genCoverageEntries :: Report -> IO [CoverageEntry] -genCoverageEntries rpt = - readTixFile rpt (reportTix rpt) >>= tixToCoverage rpt +genCoverageEntries rpt = readTixFile rpt (reportTix rpt) >>= tixToCoverage rpt --- | Emit simple coverage JSON data. -emitCoverageJSON :: - Maybe FilePath -- ^ 'Just' output file name, or 'Nothing' for - -- 'stdout'. - -> [CoverageEntry] -- ^ Coverage entries to write. +-- | Emit simple coverage data. +emitCoverage + :: Format + -- ^ Format of the report. + -- + -- @since 0.4.0.0 + -> Maybe FilePath + -- ^ 'Just' output file name, or 'Nothing' for 'stdout'. + -> [CoverageEntry] + -- ^ Coverage entries to write. -> IO () -emitCoverageJSON mb_outfile entries = wrap emit +emitCoverage fmt mb_outfile entries = wrap emit where wrap = maybe ($ stdout) (`withFile` WriteMode) mb_outfile - emit = flip hPutBuilder (buildJSON entries) + emit = flip hPutBuilder (builder entries) + builder = case fmt of + Codecov -> buildJSON + Lcov -> buildLcov -- ------------------------------------------------------------------------ @@ -180,29 +238,90 @@ dquote x = char7 '"' <> x <> char7 '"' braced x = char7 '{' <> x <> char7 '}' listify xs = mconcat (intersperse comma xs) - comma = char7 ',' hit (n, tag) = case tag of - Missed -> k <> char7 '0' - Partial -> k <> dquote (char7 '1' <> char7 '/' <> char7 '2') - Full -> k <> char7 '1' + Missed -> k <> char7 '0' + Partial {} -> k <> dquote (string7 "1/2") + Full i -> k <> intDec i where k = key (intDec n) +-- | 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' + +comma :: Builder +comma = char7 ',' + tixToCoverage :: Report -> Tix -> IO [CoverageEntry] -tixToCoverage rpt (Tix tms) = mapM (tixModuleToCoverage rpt) - (excludeModules rpt tms) +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 ("Search mix: " ++ name) - Mix path _ _ _ entries <- readMixFile (reportMixDirs rpt) tm - say rpt ("Found mix: "++ path) - let Info _ min_line max_line hits = makeInfo tm entries - lineHits = makeLineHits min_line max_line hits - path' <- ensureSrcPath rpt path - return (CoverageEntry { ce_filename = path' - , ce_hits = lineHits }) +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] @@ -217,21 +336,21 @@ -- | 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 <- readTix path - case mb_tix of - Nothing -> throwIO (TixNotFound path) - Just tix -> say rpt ("Found tix file: " ++ path) >> return 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 (readMix dirs (Right tm)) +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. @@ -239,59 +358,82 @@ 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 do say rpt ("Found source: " ++ path') - return path' - else go (path':acc) dirs + 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) = 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 msg = when (reportVerbose rpt) (hPutStrLn stderr msg) --- | Internal type synonym to represent code line hit. +-- | 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 - ![(HpcPos, Tick)] -- ^ Pair of position and hit + [(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 -> [(HpcPos, Tick)] -> LineHits -makeLineHits min_line max_line hits = ticksToHits (runSTUArray work) +makeLineHits :: Int -> Int -> [(Int, Tick, Count)] -> LineHits +makeLineHits min_line max_line hits = ticksToHits (assocs merged) where - work = - do arr <- newArray (min_line, max_line) ignored - mapM_ (updateHit arr) hits - return arr - updateHit arr (pos, hit) = - let (ls, _, _, _) = fromHpcPos pos - in updateOne arr hit ls - updateOne :: STUArray s Int Int -> Tick -> Int -> ST s () - updateOne arr hit i = - do prev <- readArray arr i - writeArray arr i (mergeEntry prev hit) - mergeEntry prev hit - | isIgnored prev = hit - | isMissed prev, isMissed hit = missed - | isFull prev, isFull hit = full - | otherwise = partial + 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 :: UArray Int Tick -> LineHits -ticksToHits arr = foldr f [] (range (bounds arr)) +ticksToHits :: [(Int, (Tick, Count))] -> LineHits +ticksToHits = foldr f [] where - f i acc = - case arr ! i of - tck | isIgnored tck -> acc - | isMissed tck -> (i, Missed) : acc - | isFull tck -> (i, Full) : acc - | otherwise -> (i, Partial) : acc + 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 @@ -299,47 +441,54 @@ partial = 1 full = 2 -isIgnored :: Int -> Bool +isIgnored :: Tick -> Bool isIgnored = (== ignored) -isMissed :: Int -> Bool +isMissed :: Tick -> Bool isMissed = (== missed) -isFull :: Int -> Bool +isPartial :: Tick -> Bool +isPartial = (== partial) + +isFull :: Tick -> Bool isFull = (== full) -notTicked, tickedOnlyTrue, tickedOnlyFalse, ticked :: Tick +notTicked, ticked :: Tick notTicked = missed -tickedOnlyTrue = partial -tickedOnlyFalse = partial ticked = full -- See also: "utils/hpc/HpcMarkup.hs" in "ghc" git repository. -makeInfo :: TixModule -> [MixEntry] -> Info -makeInfo tm = foldl' f z +makeInfo :: Int -> [Integer] -> [MixEntry] -> Info +makeInfo size tixs = foldl' f z where - z = Info 0 maxBound 0 [] - f (Info i min_line max_line acc) (pos, boxLabel) = - let binBox = case (isTicked i, isTicked (i+1)) of - (False, False) -> acc - (True, False) -> (pos, tickedOnlyTrue) : acc - (False, True) -> (pos, tickedOnlyFalse) : acc - (True, True) -> acc - tickBox = if isTicked i - then (pos, ticked) : acc - else (pos, notTicked) : acc - acc' = case boxLabel of - ExpBox {} -> tickBox - TopLevelBox {} -> tickBox - LocalBox {} -> tickBox - BinBox _ True -> binBox - _ -> acc - (ls, _, le, _) = fromHpcPos pos - in Info (i+1) (min ls min_line) (max le max_line) acc' + 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 mix file does not contain out of bound index. - isTicked n = unsafeAt arr_tix n /= 0 + -- 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 Int + arr_tix :: UArray Int Tick arr_tix = listArray (0, size - 1) (map fromIntegral tixs) - TixModule _name _hash size tixs = tm diff --git a/test/Test/Main.hs b/test/Test/Main.hs --- a/test/Test/Main.hs +++ b/test/Test/Main.hs @@ -3,46 +3,47 @@ module Test.Main (main) where -- base -import Control.Exception (SomeException (..), try) -import Control.Monad (when) -import Data.List (isSubsequenceOf) -import Data.Maybe (fromMaybe, isJust) -import System.Environment (getExecutablePath, lookupEnv, - setEnv, unsetEnv, withArgs) -import System.Exit (ExitCode) -import System.IO (hClose, openTempFile) +import Control.Exception (SomeException (..), try) +import Control.Monad (when) +import Data.List (isSubsequenceOf) +import Data.Maybe (fromMaybe, isJust) +import System.Environment (getExecutablePath, lookupEnv, + setEnv, unsetEnv, withArgs) +import System.Exit (ExitCode) +import System.IO (hClose, openTempFile) #if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) #endif -- filepath -import System.FilePath (takeFileName, ()) +import System.FilePath (takeFileName, ()) -- directory -import System.Directory (canonicalizePath, - doesDirectoryExist, - listDirectory, - removeDirectoryRecursive, - removeFile, - withCurrentDirectory) +import System.Directory (canonicalizePath, + doesDirectoryExist, + listDirectory, + removeDirectoryRecursive, + removeFile, + withCurrentDirectory) -- process -import System.Process (CreateProcess (..), - callProcess, shell, - waitForProcess, - withCreateProcess) +import System.Process (CreateProcess (..), + callProcess, shell, + waitForProcess, + withCreateProcess) -- tasty -import Test.Tasty (TestTree, defaultMain, - testGroup, withResource) -import Test.Tasty.HUnit (assertEqual, assertFailure, - testCase) +import Test.Tasty (TestTree, defaultMain, + testGroup, withResource) +import Test.Tasty.HUnit (assertEqual, assertFailure, + testCase) -- Internal import Trace.Hpc.Codecov.Discover -import qualified Trace.Hpc.Codecov.Main as HpcCodecov +import Trace.Hpc.Codecov.Exception +import qualified Trace.Hpc.Codecov.Main as HpcCodecov import Trace.Hpc.Codecov.Report @@ -65,11 +66,18 @@ , "" ] defaultMain $ testGroup "main" $ - [reportTest , cmdline, recipReport] ++ + [reportTest, cmdline, recipReport, exceptionTest] ++ [selfReportTest | not test_in_test, isJust mb_tool] ++ [discoverStackTest | not test_in_test, mb_tool == Just Stack] ++ [discoverCabalTest | not test_in_test, mb_tool == Just Cabal] +exceptionTest :: TestTree +exceptionTest = testGroup "exception" + [ testCase "NoTarget" $ assertEqual "NoTarget" "NoTarget" (show NoTarget) + , testCase "TixNotFound" $ + assertEqual "TixNotFound" "TixNotFound \"foo\"" (show (TixNotFound "foo")) + ] + reportTest :: TestTree reportTest = testGroup "report" [ testCase "mempty" $ do @@ -101,6 +109,8 @@ (shouldFail (main' ["foo:tests"])) , testCase "invalid-test-suite" (shouldFail (main' ["cabal:no-such-test"])) + , testCase "invalid-format" + (shouldFail (main' ["--format=foo"])) , testCase "help" (main' ["--help"]) , testCase "version" (main' ["--version"]) , testCase "numeric-version" (main' ["--numeric-version"]) @@ -114,6 +124,12 @@ ,"--exclude=NoSuchModule" ,"--verbose" ,"test/data/reciprocal/reciprocal.tix"]) + , testCase "recip-lcov-data-to-stdout" + (main' ["--mix=test/data/reciprocal/.hpc" + ,"--src=test/data/reciprocal" + ,"--verbose" + ,"--format=lcov" + ,"test/data/reciprocal/reciprocal.tix"]) , testCase "recip-data-no-src" (shouldFail (main' ["--mix=test/data/reciprocal/.hpc" @@ -287,6 +303,12 @@ , "--build=dot-stack-work" , "stack:project1-test.tix"] ["--work-dir=dot-stack-work"] + , t "project1" + [ "--root=" ++ testData "project1" + , "--verbose" + , "--format=lcov" + , "stack:project1-test"] + [] , withProject "project1" $ testCase "project1" $ @@ -310,7 +332,7 @@ discoverCabalTest :: TestTree discoverCabalTest = let t = buildAndTestWithCabal - withProject name act = case getAcquireAndRelease Stack name [] of + withProject name act = case getAcquireAndRelease Cabal name [] of (a,r) -> withResource a r (const act) in testGroup "discover_cabal" [ t "project1" @@ -331,6 +353,7 @@ canonical_tix_path <- canonicalizePath tix_path main' [ "--verbose" , "-x", "Main,Paths_project1" + , "-f", "lcov" , "cabal:" ++ canonical_tix_path]) ] diff --git a/test/data/project1/src/Lib.hs b/test/data/project1/src/Lib.hs --- a/test/data/project1/src/Lib.hs +++ b/test/data/project1/src/Lib.hs @@ -1,5 +1,6 @@ module Lib ( someFunc + , anotherFunc ) where someFunc :: Int -> IO () @@ -7,3 +8,10 @@ if even n then putStrLn "got even number" else putStrLn "not a even number" + +anotherFunc :: Int -> Int -> Int -> IO () +anotherFunc a b c + | 0 < a, 0 < b, 0 < c = putStrLn "all positive" + | even a, even b, even c = putStrLn "all even" + | otherwise = pure () + diff --git a/test/data/project1/stack.yaml b/test/data/project1/stack.yaml --- a/test/data/project1/stack.yaml +++ b/test/data/project1/stack.yaml @@ -17,8 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/7.yaml +resolver: lts-21.1 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/test/data/project1/test/Spec.hs b/test/data/project1/test/Spec.hs --- a/test/data/project1/test/Spec.hs +++ b/test/data/project1/test/Spec.hs @@ -1,4 +1,6 @@ import Lib main :: IO () -main = someFunc 42 +main = do + someFunc 42 + anotherFunc 1 2 (-3)