diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hpc-codecov + +## 0.1.0.0 -- 2020-02-08 + +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020, 8c6794b6 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of 8c6794b6 nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,122 @@ +hpc-codecov +=========== + +[![codecov](https://codecov.io/gh/8c6794b6/hpc-codecov/branch/master/graph/badge.svg)](https://codecov.io/gh/8c6794b6/hpc-codecov) +[![Build +Status](http://img.shields.io/travis/8c6794b6/codecov-haskell/master.svg?logo=travis)](https://travis-ci.org/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) + +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 +[hpc](https://hackage.haskell.org/package/hpc). + +The ``hpc-codecov`` executable does not try to find out the location +of ``.tix`` and ``mix`` files. Instead, let the user to explicitly +specify the file paths and directories. The rational behind the +decision is to support multiple versions of multiple build tools, such +as [cabal-install](http://hackage.haskell.org/package/cabal-install) +legacy v1-style build, v2-style build, and +[stack](https://docs.haskellstack.org/en/stable/README/). + + +Examples +-------- + +Following shows two examples for generating test coverage report of +the ``hpc-codecov`` package itself, one with ``cabal-install`` +Nix-style local build commands, and another with ``stack``. + +### With cabal-install + +First, run the tests with coverage option to generate ``.tix`` and +``mix`` files: + +```console +$ cabal --version +cabal-install version 3.0.0.0 +compiled using version 3.0.0.0 of the Cabal library +$ cabal v2-configure --enable-test --enable-coverage +$ cabal v2-test +``` + +Then generate a Codecov JSON coverage data from the ``.tix`` and +``.mix`` files: + +```console +$ proj=hpc-codecov-0.1.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 +``` + +The ``--out`` option specifies the output file to write the JSON +report. Observing the contents of ``codecov.json`` with +[``jq``](https://stedolan.github.io/jq/): + +```console +$ jq . codecov.json | head -10 +{ + "coverage": { + "src/Trace/Hpc/Codecov/Error.hs": { + "27": 1, + "30": 1, + "31": 1, + "32": 1, + "33": 1, + "34": 1, + "51": 0, +``` + +Send the resulting JSON report file to Codecov with the [bash +uploader](https://github.com/codecov/codecov-bash/). 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) +``` + +According to the Codecov +[FAQ](https://docs.codecov.io/docs/frequently-asked-questions), the +uploader should work from [Travis](https://travis-ci.org/), +[CircleCI](https://circleci.com/), and +[AppVeyor](https://www.appveyor.com/) for public projects without +Codecov token. + + +### With stack + +Build the package and run the tests with coverage option: + +```console +$ stack --numeric-version +2.1.3 +$ stack build --test --coverage +``` + +As done in ``cabal-install`` example, specify the path of ``.tix`` and +``.mix`` files. Using ``path`` sub-command to get the local hpc root +directory and dist directory: + +```console +$ hpcroot=$(stack path --local-hpc-root) +$ tix=$(find $hpcroot -name 'test-main.tix') +$ mix=$(stack path --distdir)/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) +``` + + +References +---------- + +- [HPC publication](http://ittc.ku.edu/~andygill/papers/Hpc07.pdf) +- [Codecov API reference](https://docs.codecov.io/reference) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exec/hpc-codecov.hs b/exec/hpc-codecov.hs new file mode 100644 --- /dev/null +++ b/exec/hpc-codecov.hs @@ -0,0 +1,1 @@ +import Trace.Hpc.Codecov.Main diff --git a/hpc-codecov.cabal b/hpc-codecov.cabal new file mode 100644 --- /dev/null +++ b/hpc-codecov.cabal @@ -0,0 +1,72 @@ +cabal-version: 2.0 +name: hpc-codecov +version: 0.1.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 +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 + + . + See for + more info. + +extra-source-files: + README.md + CHANGELOG.md + test/data/self.tar + test/data/reciprocal.tar + +library + hs-source-dirs: src + exposed-modules: Trace.Hpc.Codecov.Error + Trace.Hpc.Codecov.Main + Trace.Hpc.Codecov.Options + Trace.Hpc.Codecov.Report + Paths_hpc_codecov + autogen-modules: Paths_hpc_codecov + build-depends: base >= 4.10 && < 5 + , array >= 0.1 && < 0.6 + , bytestring >= 0.10 && < 0.11 + , directory >= 1.3.0 && < 1.4.0 + , filepath >= 1.4.1 && < 1.5 + , hpc >= 0.6 && < 0.7 + default-language: Haskell2010 + ghc-options: -Wall + +executable hpc-codecov + hs-source-dirs: exec + main-is: hpc-codecov.hs + build-depends: base + , hpc-codecov + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts + +test-suite test-main + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test-main.hs + other-modules: Test.Main + build-depends: base + , directory + , filepath + , hpc-codecov + -- + , tar >= 0.5 && < 0.6 + , tasty >= 1.0 && < 1.3 + , tasty-hunit >= 0.8 && < 1.0 + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts + +source-repository head + type: git + location: https://github.com/8c6794b6/hpc-codecov.git diff --git a/src/Trace/Hpc/Codecov/Error.hs b/src/Trace/Hpc/Codecov/Error.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Codecov/Error.hs @@ -0,0 +1,78 @@ +-- | +-- Module: Trace.Hpc.Codecov.Error +-- Copyright: (c) 2020 8c6794b6 +-- License: BSD3 +-- Maintainer: 8c6794b6 <8c6794b6@gmail.com> +-- +-- Error and exception related codes. + +module Trace.Hpc.Codecov.Error + ( + -- * Exception data type and handler + HpcCodecovError(..) + , withBriefUsageOnError + ) where + +-- base +import Control.Exception (Exception (..), handle) +import System.Environment (getProgName) +import System.Exit (exitFailure) + +-- | Run the given action with a handler for 'HpcCodecovError'. +-- +-- The handler will show a brief usage and call 'exitFailure' when an +-- exception was caught. +withBriefUsageOnError :: IO a -- ^ Action to perform. + -> IO a +withBriefUsageOnError = handle handler + where + handler :: HpcCodecovError -> IO a + handler e = + do putStr ("Error: " ++ displayException e) + name <- getProgName + putStrLn ("Run '" ++ name ++ " --help' for usage.") + exitFailure + +-- | Exceptions thrown during coverage report generation. +data HpcCodecovError + = NoTixFile + -- ^ Tix file path was not given. + | TixNotFound FilePath + -- ^ Tix file path was given, but not found. + | MixNotFound FilePath [FilePath] + -- ^ Mix file not found. The first field is the path specified by a + -- tix file. The second is the searched paths. + | SrcNotFound FilePath [FilePath] + -- ^ Like 'MixNotFound', but for source code specified by a mix + -- file. + | InvalidArgs [String] + -- ^ Some errors in command line argument, e.g., required value not + -- specified. + deriving (Show) + +instance Exception HpcCodecovError where + displayException = hpcCodecovErrorMessage + +hpcCodecovErrorMessage :: HpcCodecovError -> String +hpcCodecovErrorMessage e = + case e of + NoTixFile -> "no .tix file given\n" + TixNotFound tix -> "cannot find tix: " ++ show tix ++ "\n" + MixNotFound mix locs -> searchedLocations "mix" mix locs + SrcNotFound src locs -> searchedLocations "src" src locs + InvalidArgs msgs -> + case msgs of + [x] -> x + _ -> '\n' : concatMap (" - " ++) msgs + +searchedLocations :: String -> FilePath -> [FilePath] -> String +searchedLocations what path locs = + "cannot find " ++ what ++ ": " ++ show path ++ locs' + where + locs' = + case locs of + [_] -> searched "" + _ -> searched "s" + searched post = + "\nsearched location" ++ post ++ ":\n" ++ + unlines (map (" " ++) locs) diff --git a/src/Trace/Hpc/Codecov/Main.hs b/src/Trace/Hpc/Codecov/Main.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Codecov/Main.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module: Trace.Hpc.Codecov.Main +-- Copyright: (c) 2020 8c6794b6 +-- License: BSD3 +-- Maintainer: 8c6794b6 <8c6794b6@gmail.com> +-- +-- Main function for @hpc-codecov@. +-- +module Trace.Hpc.Codecov.Main (main) where + +-- base +import Control.Exception (throwIO) +import System.Environment (getArgs) + +-- Internal +import Trace.Hpc.Codecov.Error +import Trace.Hpc.Codecov.Options +import Trace.Hpc.Codecov.Report + +-- | The main function for @hpc-codecov@ executable. +main :: IO () +main = withBriefUsageOnError (getArgs >>= go) + where + go args = + case parseOptions args of + Right opts | optShowHelp opts -> printHelp + | optShowVersion opts -> printVersion + | optShowNumeric opts -> putStrLn versionString + | otherwise -> genReport (opt2rpt opts) + Left errs -> throwIO (InvalidArgs errs) diff --git a/src/Trace/Hpc/Codecov/Options.hs b/src/Trace/Hpc/Codecov/Options.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Codecov/Options.hs @@ -0,0 +1,186 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module: Trace.Hpc.Codecov.Options +-- Copyright: (c) 2020 8c6794b6 +-- License: BSD3 +-- Maintainer: 8c6794b6 <8c6794b6@gmail.com> +-- +-- Command line options for generating Codecov test coverage report. + +module Trace.Hpc.Codecov.Options + ( + -- * The Options type and predefined values + Options(..) + , defaultOptions + , emptyOptions + + -- * Command line parser for 'Options' + , parseOptions + + -- * Converter + , opt2rpt + + -- * Help message and version number + , printHelp + , printVersion + , versionString + ) where + +-- base +import Control.Exception (throw) +import Data.Version (showVersion) +import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), + OptDescr (..), getOpt, usageInfo) +import System.Environment (getProgName) + +-- Internal +import Paths_hpc_codecov (version) +import Trace.Hpc.Codecov.Error +import Trace.Hpc.Codecov.Report + +-- | Options for generating test coverage report. +data Options = Options + { optTix :: FilePath + -- ^ Input tix file. + , optMixDirs :: [FilePath] + -- ^ Directory containing mix files referred by the tix file. + , optSrcDirs :: [FilePath] + -- ^ Directory containing source codes referred by the mix files. + , optExcludes :: [String] + -- ^ Module name strings to exclude from coverage report. + , optOutFile :: Maybe FilePath + -- ^ Output file to write JSON report, if given. + , optVerbose :: Bool + -- ^ Flag for showing verbose message during coverage report + -- generation. + , optShowVersion :: Bool + -- ^ Flag for showing version. + , optShowNumeric :: Bool + -- ^ Flag for showing numeric version. + , optShowHelp :: Bool + -- ^ Flag for showing help message. + } deriving (Eq, Show) + +-- | Empty 'Options'. +emptyOptions :: Options +emptyOptions = Options + { optTix = throw NoTixFile + , optMixDirs = [] + , optSrcDirs = [] + , optExcludes = [] + , optOutFile = Nothing + , optVerbose = False + , optShowVersion = False + , optShowNumeric = False + , optShowHelp = False + } + +-- | The default 'Options'. +defaultOptions :: Options +defaultOptions = emptyOptions + { optMixDirs = [".hpc"] + , optSrcDirs = [""] + } + +-- | Commandline option oracle. +options :: [OptDescr (Options -> Options)] +options = + [ Option ['m'] ["mixdir"] + (ReqArg (\d o -> o {optMixDirs = d : optMixDirs o}) + "DIR") + ".mix file directory, can repeat\n\ + \default is .hpc" + , Option ['s'] ["srcdir"] + (ReqArg (\d o -> o {optSrcDirs = d : optSrcDirs o}) + "DIR") + "source directory, can repeat\n\ + \default is current directory" + , Option ['x'] ["exclude"] + (ReqArg (\m o -> o {optExcludes = m : optExcludes o}) + "MODULE") + "module name to exclude, can repeat" + , Option ['o'] ["out"] + (ReqArg (\p o -> o {optOutFile = Just p}) "FILE") + "output file\n\ + \default is stdout" + , Option ['v'] ["verbose"] + (NoArg (\o -> o {optVerbose = True})) + "show verbose output" + , Option [] ["version"] + (NoArg (\o -> o {optShowVersion = True})) + "show versoin and exit" + , Option [] ["numeric-version"] + (NoArg (\o -> o {optShowNumeric = True})) + "show numeric version and exit" + , Option ['h'] ["help"] + (NoArg (\o -> o {optShowHelp = True})) + "show this help" + ] + +-- | Parse command line argument and return either error messages or +-- parsed 'Options'. +parseOptions :: [String] -- ^ Command line argument strings. + -> Either [String] Options +parseOptions args = + case getOpt Permute options args of + (flags, rest, []) -> + -- Not returning error messages with missing ".tix" file + -- argument at this point, to show help and version messages + -- without specifying ".tix" file. + let opts0 = foldr (.) id flags $ emptyOptions + opts1 = fillDefaultIfNotGiven opts0 + in case rest of + [] -> Right opts1 + (tix:_) -> Right (opts1 {optTix = tix}) + (_, _, errs) -> Left errs + +fillDefaultIfNotGiven :: Options -> Options +fillDefaultIfNotGiven opts = opts + { optMixDirs = fillIf null optMixDirs + , optSrcDirs = fillIf null optSrcDirs + } + where + fillIf test fld = + let orig = fld opts + in if test orig + then fld defaultOptions + else orig + +-- | Make a 'Report' value from 'Optoins'. +opt2rpt :: Options -> Report +opt2rpt opt = Report + { reportTix = optTix opt + , reportMixDirs = optMixDirs opt + , reportSrcDirs = optSrcDirs opt + , reportExcludes = optExcludes opt + , reportOutFile = optOutFile opt + , reportVerbose = optVerbose opt + } + +-- | Print help messages. +printHelp :: IO () +printHelp = getProgName >>= putStrLn . helpMessage + +-- | Print version number of this package. +printVersion :: IO () +printVersion = + do me <- getProgName + putStrLn (me ++ " version " ++ versionString) + +-- | Help message for command line output. +helpMessage :: String -- ^ Executable program name. + -> String +helpMessage name = usageInfo header options + where + header = "\ +\Generate Codecov JSON coverage report from .tix and .mix files\n\ +\\n\ +\Usage: \n\ +\\n\ +\ " ++ name ++ " [OPTIONS] TIX_FILE\n\ +\\n\ +\Options:\n" + +-- | String representation of the version number of this package. +versionString :: String +versionString = showVersion version diff --git a/src/Trace/Hpc/Codecov/Report.hs b/src/Trace/Hpc/Codecov/Report.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Codecov/Report.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module: Trace.Hpc.Codecov.Report +-- Copyright: (c) 2020 8c6794b6 +-- License: BSD3 +-- Maintainer: 8c6794b6 <8c6794b6@gmail.com> +-- +-- Generate Codecov report data. + +module Trace.Hpc.Codecov.Report + ( -- * Types + Report(..) + , CoverageEntry(..) + , LineHits + , Hit(..) + + -- * Functions + , genReport + , genCoverageEntries + , emitCoverageJSON + ) where + +-- base +import Control.Exception (ErrorCall, handle, throwIO) +import Control.Monad (when) +import Control.Monad.ST (ST) +import Data.List (foldl', intersperse) +import System.IO (IOMode (..), hPutStrLn, stderr, stdout, + withFile) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif + +-- array +import Data.Array.Base (unsafeAt) +import Data.Array.IArray (bounds, listArray, range, (!)) +import Data.Array.MArray (newArray, readArray, writeArray) +import Data.Array.ST (STUArray, runSTUArray) +import Data.Array.Unboxed (UArray) + +-- bytestring +import Data.ByteString.Builder (Builder, char7, hPutBuilder, intDec, + string7, stringUtf8) + +-- directory +import System.Directory (doesFileExist) + +-- filepath +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) + +-- Internal +import Trace.Hpc.Codecov.Error +-- import Trace.Hpc.Codecov.Options + + +-- ------------------------------------------------------------------------ +-- +-- Exported +-- +-- ------------------------------------------------------------------------ + +-- | Data type to hold information for generating test coverage +-- report. +data Report = Report + { reportTix :: FilePath + -- ^ Input tix file. + , reportMixDirs :: [FilePath] + -- ^ Directory containing mix files referred by the tix file. + , reportSrcDirs :: [FilePath] + -- ^ Directory 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 JSON report, if given. + , reportVerbose :: Bool + -- ^ Flag for showing verbose message during report generation. + } deriving (Eq, Show) + +-- | 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. + } deriving (Eq, Show) + +-- | Pair of line number and hit tag. +type LineHits = [(Int, Hit)] + +-- | Data type to represent coverage of source code line. +data Hit + = Missed -- ^ The line is not covered at all. + | Partial -- ^ The line is partially covered. + | Full -- ^ The line is fully covered. + 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" + +-- | Generate test coverage entries. +genCoverageEntries :: Report -> IO [CoverageEntry] +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. + -> IO () +emitCoverageJSON mb_outfile entries = wrap emit + where + wrap = maybe ($ stdout) (`withFile` WriteMode) mb_outfile + emit = flip hPutBuilder (buildJSON entries) + +-- | Build simple JSON report from coverage entries. +buildJSON :: [CoverageEntry] -> Builder +buildJSON 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 ':' + 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' + where + k = key (intDec n) + +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 ("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 }) + + +-- ------------------------------------------------------------------------ +-- +-- Internal +-- +-- ------------------------------------------------------------------------ + +-- | 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 <- 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)) + where + handler :: ErrorCall -> IO a + handler _ = throwIO (MixNotFound name dirs') + dirs' = map ( (name <.> "mix")) dirs + +-- | 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 do say rpt ("Found source: " ++ path') + return path' + else go (path':acc) dirs + +-- | 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. +type Tick = Int + +-- | 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 + +-- | Make line hits from intermediate info. +makeLineHits :: Int -> Int -> [(HpcPos, Tick)] -> LineHits +makeLineHits min_line max_line hits = ticksToHits (runSTUArray work) + 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 + +-- | Convert array of ticks to list of hits. +ticksToHits :: UArray Int Tick -> LineHits +ticksToHits arr = foldr f [] (range (bounds arr)) + 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 + +ignored, missed, partial, full :: Tick +ignored = -1 +missed = 0 +partial = 1 +full = 2 + +isIgnored :: Int -> Bool +isIgnored = (== ignored) + +isMissed :: Int -> Bool +isMissed = (== missed) + +isFull :: Int -> Bool +isFull = (== full) + +notTicked, tickedOnlyTrue, tickedOnlyFalse, 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 + 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' + + -- Hope that mix file does not contain out of bound index. + isTicked n = unsafeAt arr_tix n /= 0 + + arr_tix :: UArray Int Int + 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 new file mode 100644 --- /dev/null +++ b/test/Test/Main.hs @@ -0,0 +1,163 @@ +-- | Test codes for running @hpc-codecov@ executable. +module Test.Main (main) where + +-- base +import Control.Exception (SomeException (..), try) +import System.Environment (withArgs) +import System.IO (hClose, openTempFile) + +-- filepath +import System.FilePath (dropExtension, (<.>), ()) + +-- directory +import System.Directory (removeDirectoryRecursive, + removeFile) + +-- tar +import Codec.Archive.Tar (extract) + +-- tasty +import Test.Tasty (TestTree, defaultMain, + testGroup, withResource) +import Test.Tasty.HUnit + +-- Internal +import qualified Trace.Hpc.Codecov.Main as HpcCodecov +import Trace.Hpc.Codecov.Options + + +-- ------------------------------------------------------------------------ +-- +-- Tests +-- +-- ------------------------------------------------------------------------ + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "main" + [ cmdline + , withTestTarData "self.tar" selfReport + , withTestTarData "reciprocal.tar" recipReport + ] + +cmdline :: TestTree +cmdline = testGroup "cmdline" + [ testCase "non-existing-option" + (shouldFail (main' ["--foo"])) + , testCase "non-existing-options" + (shouldFail (main' ["--foo", "--bar", "--buzz"])) + , testCase "mixdir-without-argument" + (shouldFail (main' ["--mixdir"])) + , testCase "no-tix-file" + (shouldFail (main' [])) + , testCase "non-existing-tix" + (shouldFail (main' ["no_such_file.tix"])) + , testCase "help" (main' ["--help"]) + , testCase "version" (main' ["--version"]) + , testCase "numeric-version" (main' ["--numeric-version"]) + ] + +selfReport :: TestTree +selfReport = testGroup "self" + [ testCase "self-data-to-stdout" + (main' selfHpcDataArgs) + , testCase "self-data-to-stdout-verbose" + (main' ("--verbose":selfHpcDataArgs)) + , withTempFile + (\getPath -> + testCase "self-data-to-file-verbose" + (do path <- getPath + main' (["--out=" ++ path, "--verbose"] ++ + selfHpcDataArgs))) + , testCase "self-data-no-mix-none" + (shouldFail (main' [selfTix])) + , testCase "self-data-no-mix-one" + (shouldFail (main' ["--mix=foo", selfTix])) + , testCase "self-data-no-all-two" + (shouldFail (main' ["--mix=foo", "--mix=bar", selfTix])) + ] + +recipReport :: TestTree +recipReport = testGroup "recip" + [ testCase "recip-data-to-stdout" + (main' ["--mix=test/data/reciprocal/.hpc" + ,"--src=test/data/reciprocal" + ,"--exclude=NoSuchModule" + ,"--verbose" + ,"test/data/reciprocal/reciprocal.tix"]) + , testCase "recip-data-no-src" + (shouldFail + (main' ["--mix=test/data/reciprocal/.hpc" + ,"--src=test/" + ,"--src=test/data" + ,"--verbose" + ,"test/data/reciprocal/reciprocal.tix"])) + ] + +-- ------------------------------------------------------------------------ +-- +-- Auxiliary functions +-- +-- ------------------------------------------------------------------------ + +-- | Wrapper to run 'Trace.Hpc.Codecov.Main.main' with given argument +-- strings. +main' :: [String] -> IO () +main' args = withArgs args HpcCodecov.main + +-- | Run given test with mix and tix files of tar file. +-- +-- The mix and tix packages are archived as 'test/data/XXX.tar' and +-- added as extra source file in cabal configuration. Unpacked tar +-- contents are removed after running given tests. +withTestTarData :: String -- ^ Tar file name under 'testDataDir' + -> TestTree -- ^ Test using the tar contents + -> TestTree +withTestTarData dot_tar tt = withResource acquire release (const tt) + where + acquire = do extract testDataDir (testDataDir dot_tar) + return (testDataDir dropExtension dot_tar) + release = removeDirectoryRecursive + +-- | Run test with path to temporary file. +withTempFile :: (IO FilePath -> TestTree) -> TestTree +withTempFile = withResource acquire release + where + acquire = do (path,hdl) <- openTempFile "." "test.tmp" + hClose hdl + return path + release path = removeFile path + +-- | My package name +me :: String +me = "hpc-codecov-" ++ versionString + +-- | Directory path of extracted @self.tar@. +selfDir :: FilePath +selfDir = testDataDir "self" + +-- | Relative path of tix file in @self.tar@ from project root. +selfTix :: FilePath +selfTix = selfDir "tix" me me <.> "tix" + +-- | Arguments for running test with @self.tar@ contents. +selfHpcDataArgs :: [String] +selfHpcDataArgs = + let mix = selfDir "mix" me + in ["--mix=" ++ mix, "--exclude=Paths_hpc_codecov", selfTix] + +-- | Directory containing test data. +testDataDir :: FilePath +testDataDir = "test" "data" + +-- | Pass the HUnit test when an exception was thrown, otherwise a +-- test failure. +shouldFail :: IO a -> IO () +shouldFail act = + do et_err <- try act + case et_err of + Left (SomeException {}) -> return () + _ -> assertFailure "should fail" diff --git a/test/data/reciprocal.tar b/test/data/reciprocal.tar new file mode 100644 Binary files /dev/null and b/test/data/reciprocal.tar differ diff --git a/test/data/self.tar b/test/data/self.tar new file mode 100644 Binary files /dev/null and b/test/data/self.tar differ diff --git a/test/test-main.hs b/test/test-main.hs new file mode 100644 --- /dev/null +++ b/test/test-main.hs @@ -0,0 +1,1 @@ +import Test.Main