diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Revision history for hpc-codecov +## 0.3.0.0 -- 2021-04-02 + +Modify command-line argument to support TOOL:TEST_SUITE style target, +support searching .tix and .mix files made by cabal-install and +stack. Add options to customize the search for .mix and .tix files +with temporary directories made with cabal-install and stack. + +Add new module ``Trace.Hpc.Codecov.Discover``. Rename module +``Trace.Hpc.Codecov.Error`` to ``Trace.Hpc.Codecov.Exception``. +Rename function ``main`` to ``defaultMain`` in +``Trace.Hpc.Codecov.Main``. + ## 0.2.0.2 -- 2021-03-25 Minor modification to support ghc 9.0.1. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,27 +4,157 @@ [![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?query=workflow%3ci) +[![GitHub](https://img.shields.io/github/workflow/status/8c6794b6/hpc-codecov/ci?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 -[hpc](https://hackage.haskell.org/package/hpc). +[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). -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/). +The ``hpc-codecov`` executable can search ``.tix`` and ``mix`` files +under the directories made by the +[cabal-install](http://hackage.haskell.org/package/cabal-install) and +[stack](https://docs.haskellstack.org/en/stable/README/) build tools. +The executable also has options to explicitly specify the file paths +and directories for ``.tix`` and ``mix`` files, to support generating +reports with test data made by other build tools than +``cabal-install`` and ``stack``. +Installing +---------- + +### From Package Repository + +``hpc-codecov`` is available from +[Hackage](https://hackage.haskell.org/package/hpc-codecov) and +[Stackage](https://www.stackage.org/lts/package/hpc-codecov). To +install with ``cabal-install``, run: + +```console +$ cabal install hpc-codecov +``` + +To install with ``stack``, run: + +```console +$ stack install hpc-codecov +``` + +### Pre-compiled binaries + +For Windows, MacOS, and Linux (with glibc and libgmp), pre-compiled +binary executables are available +[here](https://github.com/8c6794b6/hpc-codecov/releases/latest). + + +QuickStart +---------- + +To illustrate an example, initializing sample project named +``my-project`` with ``cabal-install``: + +```console +$ cabal --version +cabal-install version 3.4.0.0 +compiled using version 3.4.0.0 of the Cabal library +$ cabal init --simple --tests --test-dir=test -p my-project +``` + +Directory contents look like below: + +```console +. +├── app +│   └── Main.hs +├── CHANGELOG.md +├── my-project.cabal +├── src +│   └── MyLib.hs +└── tests + └── MyLibTest.hs +``` + +Run tests with coverage option: + +```console +$ cabal test --enable-coverage +``` + +Write Codecov coverage report to ``codecov.json``: + +```console +$ hpc-codecov cabal:my-project-test -X my-project -o codecov.json +``` + +Show coverage report contents: + +```console +$ cat codecov.json +{"coverage":{"test/MyLibTest.hs":{"4":1}}} +``` + + +Using in GitHub workflow +------------------------ + +See +[hpc-codecov-action](https://github.com/8c6794b6/hpc-codecov-action) +to generate Codecov coverage report from GitHub workflow. + + Examples -------- -Following shows two examples for generating test coverage report of -the ``hpc-codecov`` package itself, one with ``cabal-install`` +### Showing help + +Show usage information: + +```console +$ hpc-codecov --help +``` + +### Project using cabal-install + +Search under directory made by ``cabal-install`` , generating a report +for test suite named ``my-project-test``. Skip searching under the +directories with base name ``my-project``, and exclude modules named +``Main`` and ``Paths_my_project`` from the report. Note the use of +comma to separate multiple values for the ``-x`` option: + +```console +$ hpc-codecov -X my-project -x Main,Paths_my_project cabal:my-project-test +``` + +### Project using stack + +Search under directory made by ``stack`` for test suite named +``my-project-test``, show verbose information, and write output to +``codecov.json``: + +```console +$ hpc-codecov --verbose -o codecov.json stack:my-project-test +``` + +### Project using stack, with multiple packages + +Search under directory made by ``stack`` for combined report of +multiple cabal packages, and write output to ``codecov.json``: + +```consle +$ hpc-codecov stack:all -o codecov.json +``` + + +Low-level examples +------------------ + +The following shows two examples for generating a test coverage report +of the ``hpc-codecov`` package itself without specifying the build +tool. One with using the build artifacts made by ``cabal-install`` Nix-style local build commands, and another with ``stack``. ### With cabal-install @@ -34,8 +164,8 @@ ```console $ cabal --version -cabal-install version 3.0.0.0 -compiled using version 3.0.0.0 of the Cabal library +cabal-install version 3.4.0.0 +compiled using version 3.4.0.0 of the Cabal library $ cabal v2-configure --enable-test --enable-coverage $ cabal v2-test ``` @@ -44,7 +174,7 @@ ``.mix`` files: ```console -$ proj=hpc-codecov-0.1.0.0 +$ proj=hpc-codecov-0.3.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 @@ -58,14 +188,14 @@ $ 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, + "src/Trace/Hpc/Codecov/Options.hs": { + "48": 1, + "50": 1, + "52": 1, + "54": 1, + "56": 1, + "59": 1, + "63": 1, ``` Send the resulting JSON report file to Codecov with the [bash @@ -80,10 +210,11 @@ 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. +uploader should work from [Travis](https://travis-ci.com/), +[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. ### With stack @@ -92,7 +223,7 @@ ```console $ stack --numeric-version -2.3.3 +2.5.1 $ stack build --test --coverage ``` diff --git a/app/hpc-codecov.hs b/app/hpc-codecov.hs new file mode 100644 --- /dev/null +++ b/app/hpc-codecov.hs @@ -0,0 +1,4 @@ +import Trace.Hpc.Codecov.Main + +main :: IO () +main = defaultMain diff --git a/exec/hpc-codecov.hs b/exec/hpc-codecov.hs deleted file mode 100644 --- a/exec/hpc-codecov.hs +++ /dev/null @@ -1,4 +0,0 @@ -import qualified Trace.Hpc.Codecov.Main as LibMain - -main :: IO () -main = LibMain.main diff --git a/hpc-codecov.cabal b/hpc-codecov.cabal --- a/hpc-codecov.cabal +++ b/hpc-codecov.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: hpc-codecov -version: 0.2.0.2 +version: 0.3.0.0 synopsis: Generate codecov report from hpc data license: BSD3 license-file: LICENSE @@ -22,8 +22,21 @@ extra-source-files: README.md CHANGELOG.md - test/data/self.tar - test/data/reciprocal.tar + -- + test/data/reciprocal/reciprocal.hs + test/data/reciprocal/reciprocal.tix + test/data/reciprocal/.hpc/Main.mix + -- + test/data/project1/ChangeLog.md + test/data/project1/LICENSE + test/data/project1/README.md + test/data/project1/Setup.hs + test/data/project1/app/Main.hs + test/data/project1/package.yaml + test/data/project1/src/Lib.hs + test/data/project1/test/Spec.hs + test/data/project1/project1.cabal + test/data/project1/stack.yaml tested-with: GHC == 8.2.2 , GHC == 8.4.4 @@ -34,11 +47,12 @@ library hs-source-dirs: src - exposed-modules: Trace.Hpc.Codecov.Error + exposed-modules: Trace.Hpc.Codecov.Exception + Trace.Hpc.Codecov.Discover Trace.Hpc.Codecov.Main - Trace.Hpc.Codecov.Options Trace.Hpc.Codecov.Report Paths_hpc_codecov + other-modules: Trace.Hpc.Codecov.Options autogen-modules: Paths_hpc_codecov build-depends: base >= 4.10 && < 5 , array >= 0.1 && < 0.6 @@ -50,7 +64,7 @@ ghc-options: -Wall executable hpc-codecov - hs-source-dirs: exec + hs-source-dirs: app main-is: hpc-codecov.hs build-depends: base , hpc-codecov @@ -67,7 +81,7 @@ , filepath , hpc-codecov -- - , tar >= 0.5 && < 0.6 + , process >= 1.6 && < 1.7 , tasty >= 1.0 && < 1.5 , tasty-hunit >= 0.8 && < 1.0 default-language: Haskell2010 diff --git a/src/Trace/Hpc/Codecov/Discover.hs b/src/Trace/Hpc/Codecov/Discover.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Codecov/Discover.hs @@ -0,0 +1,280 @@ +-- | +-- Module: Trace.Hpc.Codecov.Discover +-- Copyright: (c) 2021 8c6794b6 +-- License: BSD3 +-- Maintainer: 8c6794b6 <8c6794b6@gmail.com> +-- +-- Walk through directories and find hpc data. + +module Trace.Hpc.Codecov.Discover + ( -- * Discover function and types + discover + , DiscoverArgs(..) + , BuildTool(..) + + -- * Auxiliary + , foldDir + , defaultIgnored + , foldDirWithIgnoring + ) where + +-- base +import Control.Exception (throwIO) +import Control.Monad (when) +import Data.Maybe (isNothing) +import System.IO (hPutStrLn, stderr) + +-- directory +import System.Directory (doesDirectoryExist, doesFileExist, + listDirectory) + +-- filepath +import System.FilePath (splitFileName, takeExtension, + takeFileName, (<.>), ()) + +-- Internal +import Trace.Hpc.Codecov.Exception +import Trace.Hpc.Codecov.Report + + +-- ------------------------------------------------------------------------ +-- +-- Types +-- +-- ------------------------------------------------------------------------ + +-- | Data type to hold arguments of 'discover' function. +data DiscoverArgs = DiscoverArgs + { da_tool :: BuildTool + -- ^ Tool used to build Haskell cabal package. + , da_testsuite :: String + -- ^ Test suite name to search for @.tix@ file. + , da_rootdir :: FilePath + -- ^ The project root directory. + , da_builddir :: Maybe String + -- ^ Name of the temporary build directory made by the build tool. + , da_skipdirs :: [String] + -- ^ Directories to skip while searching for scanning data. + , da_verbose :: Bool + -- ^ Flag for shwoing verbose information. + } + +-- | Tool used for building Haskell package source codes. +data BuildTool + = Cabal + -- ^ For . + | Stack + -- ^ For . + deriving (Eq) + +instance Show BuildTool where + show tool = case tool of + Cabal -> "cabal" + Stack -> "stack" + +-- | Walk thorugh directory and search for @.mix@ directories, Haskell +-- source code directories, and @.tix@ file. +discover :: DiscoverArgs -> IO Report +discover da = do + let build_dir = case da_builddir da of + Nothing -> defaultBuildDirName (da_tool da) + Just dir -> dir + list_msg = concatMap (\p -> " - " ++ p ++ "\n") + skipped_dirs_msg = + if null (da_skipdirs da) + then "No directory specified to skip during discover" + else "Skipping directories: " ++ unwords (da_skipdirs da) + + say da $ + "Starting discover for " ++ show (da_tool da) ++ "\n" ++ + "Scanning under \"" ++ da_rootdir da ++ "\"" ++ + " for .cabal files and \"" ++ build_dir ++ "\"\n" ++ + skipped_dirs_msg + + (src_dirs, build_dirs) <- findSrcDirsAndBuildDirs da build_dir + say da $ + "Scanned:\n" ++ + " Directories containing .cabal files:\n" ++ list_msg src_dirs ++ + " Build dirs:\n" ++ list_msg build_dirs + + tix_path <- parseTixish (da_testsuite da) + (mb_tix, mixs) <- findTixAndMix da tix_path build_dirs + + found_tix_path <- case mb_tix of + Just tix -> pure tix + Nothing -> throwIO $ TestSuiteNotFound (da_testsuite da) + + say da $ + "Discovered:\n" ++ + " Tix file: \n" ++ list_msg [found_tix_path] ++ + " Mix dirs: \n" ++ list_msg mixs + + return $ mempty + { reportTix = found_tix_path + , reportMixDirs = mixs + , reportSrcDirs = src_dirs + } + +data TixPath + = UnresolvedTixPath FilePath + | ResolvedTixPath FilePath + +parseTixish :: String -> IO TixPath +parseTixish str = do + let tix1 = if takeExtension str == ".tix" + then str + else str <.> "tix" + tix1_found <- doesFileExist tix1 + if tix1_found + then return $ ResolvedTixPath tix1 + else return $ UnresolvedTixPath tix1 + +defaultBuildDirName :: BuildTool -> String +defaultBuildDirName tool = case tool of + Cabal -> "dist-newstyle" + Stack -> ".stack-work" + +-- | Show mssage to 'stdrr'. +say :: DiscoverArgs -> String -> IO () +say da msg = when (da_verbose da) $ hPutStrLn stderr msg + +findSrcDirsAndBuildDirs + :: DiscoverArgs -> String -> IO ([FilePath], [FilePath]) +findSrcDirsAndBuildDirs da build_dir = do + ds <- if null $ da_rootdir da + then listDirectory "." + else pure [da_rootdir da] + foldDirWithIgnoring ignored f z ds + where + z = ([], []) + f p acc@(src_dirs, dirs) + | takeExtension p_file == ".cabal" = pure (p_dir:src_dirs, dirs) + | p_file == build_dir = pure (src_dirs, p:dirs) + | otherwise = pure acc + where + (p_dir, p_file) = splitFileName p + ignored = build_dir : (defaultIgnored ++ da_skipdirs da) + +findTixAndMix + :: DiscoverArgs -> TixPath -> [FilePath] + -> IO (Maybe FilePath, [FilePath]) +findTixAndMix da tixish build_dirs = case da_tool da of + Stack -> findForStack excludes tixish build_dirs + Cabal -> findForCabal excludes tixish build_dirs + where + excludes = defaultIgnored ++ da_skipdirs da + + +-- ------------------------------------------------------------------------ +-- +-- Searching mix and tix for stack +-- +-- ------------------------------------------------------------------------ + +findForStack + :: [String] -> TixPath -> [FilePath] -> IO (Maybe FilePath, [FilePath]) +findForStack excludes tx dirs = do + mb_tix <- case tx of + ResolvedTixPath path -> pure $ Just path + UnresolvedTixPath name -> findStackTix excludes name dirs + mixs <- findStackMix excludes dirs + pure (mb_tix, mixs) + +findStackMix :: [String] -> [FilePath] -> IO [FilePath] +findStackMix ignored dirs = foldDirWithIgnoring ignored f [] dist_dirs + where + dist_dirs = map ( "dist") dirs + f p acc = + pure $ if takeFileName p == "hpc" + then p : acc + else acc + +findStackTix :: [String] -> String -> [FilePath] -> IO (Maybe FilePath) +findStackTix ignored tix_name dirs = go f Nothing install_dirs + where + go = foldDirWithIgnoring ignored + install_dirs = map ( "install") dirs + f _ (Just tix) = return (Just tix) + f p Nothing = if takeFileName p == tix_name + then return (Just p) + else return Nothing + + +-- ------------------------------------------------------------------------ +-- +-- Searching mix and tix for cabal-install +-- +-- ------------------------------------------------------------------------ + +findForCabal + :: [String] -> TixPath -> [FilePath] -> IO (Maybe FilePath, [FilePath]) +findForCabal ignored tx = foldDirWithIgnoring ignored f z + where + f = case tx of + ResolvedTixPath _ -> findVanilla ignored + UnresolvedTixPath tix_name -> \p acc@(mb_tix, dirs) -> do + if isNothing mb_tix && takeFileName p == tix_name + then return (Just p, dirs) + else findVanilla ignored p acc + + z = case tx of + ResolvedTixPath path -> (Just path, []) + _ -> (Nothing, []) + +findVanilla + :: [String] -> FilePath -> (Maybe FilePath, [FilePath]) + -> IO (Maybe FilePath, [FilePath]) +findVanilla ignored p acc@(mb_tix, dirs) = do + if takeFileName p == "vanilla" + then do + let mix = p "mix" + mix_exist <- doesDirectoryExist mix + if mix_exist + then do + let f xs = [mix x| x <- xs, x `notElem` ignored] + contents <- f <$> listDirectory mix + return (mb_tix, contents ++ dirs) + else return (mb_tix, dirs) + else return acc + + +-- ------------------------------------------------------------------------ +-- +-- Simple directory walker +-- +-- ------------------------------------------------------------------------ + +-- | Variant of 'foldDirWithIgnoring' with 'defaultIgnored'. +foldDir :: (FilePath -> a -> IO a) -> a -> [FilePath] -> IO a +foldDir = foldDirWithIgnoring defaultIgnored + +-- | Default directory base names to ignore. +defaultIgnored :: [String] +defaultIgnored = [".git", ".github"] + +-- | Fold under given directory. +foldDirWithIgnoring + :: [String] + -- ^ Directory base names to skip. + -> (FilePath -> a -> IO a) + -- ^ Accumulator function. + -> a + -- ^ Initial accumulator value. + -> [FilePath] + -- ^ Directories to walk through. + -> IO a +foldDirWithIgnoring ignored f = go + where + go acc0 [] = return acc0 + go acc0 (dir:dirs) = do + acc1 <- f dir acc0 + if takeFileName dir `elem` ignored + then go acc1 dirs + else do + is_dir <- doesDirectoryExist dir + if not is_dir + then go acc1 dirs + else do + contents <- map (dir ) <$> listDirectory dir + acc2 <- go acc1 contents + go acc2 dirs diff --git a/src/Trace/Hpc/Codecov/Error.hs b/src/Trace/Hpc/Codecov/Error.hs deleted file mode 100644 --- a/src/Trace/Hpc/Codecov/Error.hs +++ /dev/null @@ -1,78 +0,0 @@ --- | --- 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/Exception.hs b/src/Trace/Hpc/Codecov/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Codecov/Exception.hs @@ -0,0 +1,85 @@ +-- | +-- Module: Trace.Hpc.Codecov.Exception +-- Copyright: (c) 2020 8c6794b6 +-- License: BSD3 +-- Maintainer: 8c6794b6 <8c6794b6@gmail.com> +-- +-- Error and exception related codes. + +module Trace.Hpc.Codecov.Exception + ( + -- * 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 + = NoTarget + -- ^ Target 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. + | InvalidBuildTool String + -- ^ Invalid build tool. + | TestSuiteNotFound String + -- ^ Test suite was given, but not found. + | 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 + NoTarget -> "no TARGET was given\n" + TixNotFound tix -> "cannot find tix: " ++ show tix ++ "\n" + MixNotFound mix locs -> searchedLocations "mix" mix locs + SrcNotFound src locs -> searchedLocations "src" src locs + InvalidBuildTool tool-> "invalid build tool: `" ++ tool ++ "'\n" + TestSuiteNotFound name -> + "cannot find tix for test suite: " ++ show name ++ "\n" + 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 --- a/src/Trace/Hpc/Codecov/Main.hs +++ b/src/Trace/Hpc/Codecov/Main.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} -- | -- Module: Trace.Hpc.Codecov.Main -- Copyright: (c) 2020 8c6794b6 @@ -7,25 +6,25 @@ -- -- Main function for @hpc-codecov@. -- -module Trace.Hpc.Codecov.Main (main) where +module Trace.Hpc.Codecov.Main (defaultMain) where -- base -import Control.Exception (throwIO) -import System.Environment (getArgs) +import Control.Exception (throwIO) +import System.Environment (getArgs) -- Internal -import Trace.Hpc.Codecov.Error +import Trace.Hpc.Codecov.Exception import Trace.Hpc.Codecov.Options import Trace.Hpc.Codecov.Report -- | The main function for @hpc-codecov@ executable. -main :: IO () -main = withBriefUsageOnError (getArgs >>= go) +defaultMain :: IO () +defaultMain = 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) + | otherwise -> opt2rpt opts >>= genReport Left errs -> throwIO (InvalidArgs errs) 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 @@ -27,15 +27,20 @@ ) where -- base -import Control.Exception (throw) -import Data.Version (showVersion) -import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), - OptDescr (..), getOpt, usageInfo) -import System.Environment (getProgName) +import Control.Exception (throw, throwIO) +import Data.Version (showVersion) +import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), + OptDescr (..), getOpt, usageInfo) +import System.Environment (getProgName) +-- directory +import System.Directory (doesFileExist) + + -- Internal -import Paths_hpc_codecov (version) -import Trace.Hpc.Codecov.Error +import Paths_hpc_codecov (version) +import Trace.Hpc.Codecov.Discover +import Trace.Hpc.Codecov.Exception import Trace.Hpc.Codecov.Report -- | Options for generating test coverage report. @@ -50,26 +55,38 @@ -- ^ 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. + + , optRootDir :: FilePath + -- ^ Project root directory for the build tool. + , optBuildDir :: Maybe FilePath + -- ^ Name of the build directory used by the build tool + , optSkipDirs :: [String] + -- ^ Directories to ignore while discovering. + , 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 + { optTix = throw NoTarget , optMixDirs = [] , optSrcDirs = [] , optExcludes = [] , optOutFile = Nothing , optVerbose = False + , optRootDir = "" + , optBuildDir = Nothing + , optSkipDirs = [] , optShowVersion = False , optShowNumeric = False , optShowHelp = False @@ -85,36 +102,57 @@ -- | Commandline option oracle. options :: [OptDescr (Options -> Options)] options = - [ Option ['m'] ["mixdir"] - (ReqArg (\d o -> o {optMixDirs = d : optMixDirs o}) - "DIR") + [ Option ['m'] ["mix"] + (ReqArg (\d o -> o {optMixDirs = uncommas d ++ optMixDirs o}) + "DIR") ".mix file directory, can repeat\n\ - \default is .hpc" - , Option ['s'] ["srcdir"] - (ReqArg (\d o -> o {optSrcDirs = d : optSrcDirs o}) + \(default: .hpc)" + , Option ['s'] ["src"] + (ReqArg (\d o -> o {optSrcDirs = uncommas d ++ optSrcDirs o}) "DIR") - "source directory, can repeat\n\ - \default is current directory" + "Source directory, can repeat\n\ + \(default: current directory)" , Option ['x'] ["exclude"] - (ReqArg (\m o -> o {optExcludes = m : optExcludes o}) + (ReqArg (\m o -> o {optExcludes = uncommas m ++ optExcludes o}) "MODULE") - "module name to exclude, can repeat" + "Module name to exclude, can repeat" , Option ['o'] ["out"] (ReqArg (\p o -> o {optOutFile = Just p}) "FILE") - "output file\n\ - \default is stdout" + "Output file\n\ + \(default: stdout)" + + , Option ['r'] ["root"] + (ReqArg (\d o -> o {optRootDir = d}) + "DIR") + "Project root directory for TOOL\n\ + \Usually the directory containing\n\ + \'stack.yaml' or 'cabal.project'\n\ + \(default: current directory)" + , Option ['b'] ["build"] + (ReqArg (\d o -> o {optBuildDir = Just d}) + "DIR") + "Build directory made by the TOOL\n\ + \(default:\n\ + \ - '.stack-work' for stack\n\ + \ - 'dist-newstyle' for cabal)" + , Option ['X'] ["skip"] + (ReqArg (\d o -> o {optSkipDirs = uncommas d ++ optSkipDirs o}) + "DIR") + "Basename of directory to skip while\n\ + \searching data for TOOL, can repeat" + , Option ['v'] ["verbose"] (NoArg (\o -> o {optVerbose = True})) - "show verbose output" + "Show verbose output" , Option [] ["version"] (NoArg (\o -> o {optShowVersion = True})) - "show versoin and exit" + "Show versoin and exit" , Option [] ["numeric-version"] (NoArg (\o -> o {optShowNumeric = True})) - "show numeric version and exit" + "Show numeric version and exit" , Option ['h'] ["help"] (NoArg (\o -> o {optShowHelp = True})) - "show this help" + "Show this help and exit" ] -- | Parse command line argument and return either error messages or @@ -146,16 +184,56 @@ then fld defaultOptions else orig +-- | Representation of @TARGET@ argument. +data Target + = TixFile FilePath + | TestSuite BuildTool String + +parseTarget :: String -> IO Target +parseTarget str = do + -- Detecting file existence before separating with ':', to support + -- directory path containing ':' under Windows. + file_found <- doesFileExist str + if file_found + then pure $ TixFile str + else case break (== ':') str of + ("cabal", ':':name) -> pure $ TestSuite Cabal name + ("stack", ':':name) -> pure $ TestSuite Stack name + (tool, ':':_) -> throwIO $ InvalidBuildTool tool + _ -> pure $ TixFile str + +uncommas :: String -> [String] +uncommas = go + where + go str = case break (== ',') str of + (cs, ',':rest) -> cs : go rest + (cs, _) -> [cs] + -- | 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 - } +opt2rpt :: Options -> IO Report +opt2rpt opt = do + let rpt1 = mempty + { reportMixDirs = optMixDirs opt + , reportSrcDirs = optSrcDirs opt + , reportExcludes = optExcludes opt + , reportOutFile = optOutFile opt + , reportVerbose = verbose + } + tix = optTix opt + verbose = optVerbose opt + target <- parseTarget tix + case target of + TixFile path -> pure (rpt1 {reportTix = path}) + TestSuite tool name -> do + rpt2 <- discover DiscoverArgs + { da_tool = tool + , da_testsuite = name + , da_rootdir = optRootDir opt + , da_builddir = optBuildDir opt + , da_skipdirs = optSkipDirs opt + , da_verbose = verbose + } + pure $ rpt1 `mappend` rpt2 -- | Print help messages. printHelp :: IO () @@ -170,16 +248,25 @@ -- | Help message for command line output. helpMessage :: String -- ^ Executable program name. -> String -helpMessage name = usageInfo header options +helpMessage name = usageInfo header options ++ footer where - header = "\ -\Generate Codecov JSON coverage report from .tix and .mix files\n\ + header = "USAGE: " ++ name ++ " [OPTIONS] TARGET\n\ \\n\ -\Usage: \n\ +\Generate Codecov JSON coverage report for Haskell source codes\n\ +\from .tix and .mix files made with hpc.\n\ \\n\ -\ " ++ name ++ " [OPTIONS] TIX_FILE\n\ +\TARGET is either a path to .tix file or 'TOOL:TEST_SUITE'.\n\ +\Supported TOOL values are 'stack' and 'cabal'. When the TOOL is\n\ +\'stack' and building project with multiple packages, use 'all' as\n\ +\TEST_SUITE value to refer the combined report.\n\ \\n\ -\Options:\n" +\OPTIONS:\n" + footer = "\ +\\n\ +\For more info, see:\n\ +\\n\ +\ https://github.com/8c6794b6/hpc-codecov#readme\n\ +\\n" -- | String representation of the version number of this package. versionString :: String 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 @@ -21,41 +21,42 @@ ) 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) +import Control.Exception (ErrorCall, handle, throw, throwIO) +import Control.Monad (mplus, when) +import Control.Monad.ST (ST) +import Data.Function (on) +import Data.List (foldl', intersperse) +import System.IO (IOMode (..), hPutStrLn, stderr, stdout, + withFile) #if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) +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) +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) +import Data.ByteString.Builder (Builder, char7, hPutBuilder, intDec, + string7, stringUtf8) -- directory -import System.Directory (doesFileExist) +import System.Directory (doesFileExist) -- filepath -import System.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) +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 +import Trace.Hpc.Codecov.Exception -- ------------------------------------------------------------------------ @@ -80,6 +81,36 @@ , reportVerbose :: Bool -- ^ Flag for showing verbose message during report generation. } deriving (Eq, Show) + +#if MIN_VERSION_base(4,11,0) +instance Semigroup Report where + (<>) = mappendReport +#endif + +instance Monoid Report where + mempty = emptyReport + mappend = mappendReport + +emptyReport :: Report +emptyReport = Report + { reportTix = throw NoTarget + , reportMixDirs = [] + , reportSrcDirs = [] + , reportExcludes = [] + , reportOutFile = Nothing + , reportVerbose = False + } + +mappendReport :: Report -> Report -> Report +mappendReport r1 r2 = + let extend f = ((<>) `on` f) 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 + } -- | Single file entry in coverage report. -- diff --git a/test/Test/Main.hs b/test/Test/Main.hs --- a/test/Test/Main.hs +++ b/test/Test/Main.hs @@ -1,29 +1,49 @@ +{-# LANGUAGE CPP #-} -- | 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) +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 ((<>)) +#endif + + -- filepath -import System.FilePath (dropExtension, (<.>), ()) +import System.FilePath (takeFileName, ()) -- directory -import System.Directory (removeDirectoryRecursive, - removeFile) +import System.Directory (canonicalizePath, + doesDirectoryExist, + listDirectory, + removeDirectoryRecursive, + removeFile, + withCurrentDirectory) --- tar -import Codec.Archive.Tar (extract) +-- process +import System.Process (CreateProcess (..), + callProcess, shell, + waitForProcess, + withCreateProcess) -- tasty -import Test.Tasty (TestTree, defaultMain, - testGroup, withResource) -import Test.Tasty.HUnit +import Test.Tasty (TestTree, defaultMain, + testGroup, withResource) +import Test.Tasty.HUnit (assertEqual, assertFailure, + testCase) -- Internal -import qualified Trace.Hpc.Codecov.Main as HpcCodecov -import Trace.Hpc.Codecov.Options +import Trace.Hpc.Codecov.Discover +import qualified Trace.Hpc.Codecov.Main as HpcCodecov +import Trace.Hpc.Codecov.Report -- ------------------------------------------------------------------------ @@ -33,16 +53,38 @@ -- ------------------------------------------------------------------------ main :: IO () -main = defaultMain tests +main = do + test_in_test <- isTestInTest + mb_tool <- getBuildTool -tests :: TestTree -tests = - testGroup "main" - [ cmdline - , withTestTarData "self.tar" selfReport - , withTestTarData "reciprocal.tar" recipReport - ] + when test_in_test $ putStr $ unlines + [ "" + , "=================================" + , "Running test to generate hpc data" + , "=================================" + , "" ] + defaultMain $ testGroup "main" $ + [reportTest , cmdline, recipReport] ++ + [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] + +reportTest :: TestTree +reportTest = testGroup "report" + [ testCase "mempty" $ do + shouldFail (print $ reportTix mempty) + assertEqual "empty mix dirs" (reportMixDirs mempty) [] + assertEqual "empty src dirs" (reportSrcDirs mempty) [] + assertEqual "non verbose" (reportVerbose mempty) False + let r1 = mempty { reportExcludes = ["M1"] } + r2 = mempty { reportExcludes = ["M2", "M3"] + , reportVerbose = True } + r3 = r1 <> r2 + assertEqual "<> for verbose" (reportVerbose r3) True + assertEqual "<> for excludes" (reportExcludes r3) ["M1","M2","M3"] + ] + cmdline :: TestTree cmdline = testGroup "cmdline" [ testCase "non-existing-option" @@ -50,36 +92,20 @@ , testCase "non-existing-options" (shouldFail (main' ["--foo", "--bar", "--buzz"])) , testCase "mixdir-without-argument" - (shouldFail (main' ["--mixdir"])) + (shouldFail (main' ["--mix"])) , testCase "no-tix-file" (shouldFail (main' [])) , testCase "non-existing-tix" (shouldFail (main' ["no_such_file.tix"])) + , testCase "invalid-build-tool" + (shouldFail (main' ["foo:tests"])) + , testCase "invalid-test-suite" + (shouldFail (main' ["cabal:no-such-test"])) , 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" @@ -97,30 +123,291 @@ ,"test/data/reciprocal/reciprocal.tix"])) ] +-- Note: Running test to generate .mix and .tix of hpc-codecov package +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The test recursively runs itself to generate .mix and .tix files of +-- the hpc-codecov package itself. +-- +-- To terminate the recursive run, the "main" function in this module +-- is looking up an environment variable to check whether the test is +-- running inside the test or not. Recursive run is done only for the +-- known build tool (e.g.: cabal install, stack). + +selfReportTest :: TestTree +selfReportTest = withTempDir work1 + where + work1 getDir = + withResource (acquire getDir) release selfReport + acquire getDir = + setEnv testInTestKey "TRUE" >> getDir >>= getSelfReportArgs + release _ = + unsetEnv testInTestKey + +-- | Self Report Arguments +data SRA = + SRA { sra_tix :: FilePath + , sra_mixs :: [FilePath] + , sra_excludes :: [String] + , sra_verbose :: Bool + , sra_out :: Maybe FilePath + } + +emptySRA :: SRA +emptySRA = SRA { sra_tix = "" + , sra_mixs = [] + , sra_excludes = [] + , sra_verbose = False + , sra_out = Nothing } + +getBuildTool :: IO (Maybe BuildTool) +getBuildTool = do + path <- getExecutablePath + if ".stack-work" `isSubsequenceOf` path + then return $ Just Stack + else if "dist-newstyle" `isSubsequenceOf` path + then return $ Just Cabal + else return Nothing + +getSelfReportArgs :: FilePath -> IO SRA +getSelfReportArgs builddir = do + mb_tool <- getBuildTool + case mb_tool of + Just Stack -> getSelfReportStackArgs builddir + Just Cabal -> getSelfReportCabalArgs setupV2 builddir + _ -> error "Cannot determine build tool" + +getSelfReportStackArgs :: FilePath -> IO SRA +getSelfReportStackArgs wd = do + callProcess "stack" [ "--work-dir=" ++ wd, "test", "--coverage"] + mb_tix <- findUnder (\p -> takeFileName p == "test-main.tix") wd + mb_mix <- findUnder (\p -> takeFileName p == "hpc") (wd "dist") + case (mb_tix, mb_mix) of + (Just tix, Just mix) -> do + return emptySRA { sra_tix = tix + , sra_mixs = [mix] + , sra_excludes = ["Paths_hpc_codecov"] } + _ -> error "getting arguments for self test with stack failed" + +-- setupV1 :: FilePath -> IO () +-- setupV1 bd = bracket acquire release work +-- where +-- -- Cabal v1 style build complains when "GHC_PACKAGE_PATH" +-- -- environment were set, manually removing the variable. +-- key = "GHC_PACKAGE_PATH" + +-- acquire = do +-- mb_ghc_pkg_path <- lookupEnv key +-- putStrLn $ "GHC_PACKAGE_PATH: " ++ show mb_ghc_pkg_path +-- unsetEnv key +-- pure mb_ghc_pkg_path + +-- release = mapM_ (setEnv key) + +-- work _ = do +-- let setup args = callProcess "runhaskell" ("Setup.hs" : args) + +-- setup [ "configure", "--builddir=" ++ bd +-- , "--enable-test", "--enable-coverage" +-- , "--package-db=/build/package.conf.d" ] + +-- setup ["build", "--builddir=" ++ bd] +-- setup ["test", "--builddir=" ++ bd] + +setupV2 :: FilePath -> IO () +setupV2 bd = + callProcess "cabal" [ "test", "--builddir=" ++ bd, "--enable-coverage"] + +getSelfReportCabalArgs :: (FilePath -> IO ()) -> FilePath -> IO SRA +getSelfReportCabalArgs setup bd = do + setup bd + mb_tix <- findUnder (\p -> takeFileName p == "test-main.tix") bd + putStrLn $ "tix: " ++ show mb_tix + mb_vanilla <- findUnder (\p -> takeFileName p == "vanilla") bd + putStrLn $ "vanilla: " ++ show mb_vanilla + case (mb_tix, mb_vanilla) of + (Nothing, Nothing) -> error "failed to find tix and vanilla" + (Nothing, _) -> error "failed to find tix" + (_, Nothing) -> error "failed to find vanilla" + (Just tix, Just vanilla) -> do + let mixdir = vanilla "mix" + mixs <- map (mixdir ) <$> listDirectory mixdir + return emptySRA { sra_tix = tix + , sra_mixs = mixs + , sra_excludes = ["Main", "Paths_hpc_codecov"] } + +selfReport :: IO SRA -> TestTree +selfReport getArgs = testGroup "self" + [ testCase "self-data-to-stdout" + (getArgs >>= sraMain) + , testCase "self-data-to-stdout-verbose" + (do args <- getArgs + sraMain (args {sra_verbose=True})) + , withTempFile + (\getPath -> + testCase "self-data-to-file-verbose" + (do path <- getPath + args <- getArgs + sraMain (args {sra_out=Just path + ,sra_verbose=True}))) + , testCase "self-data-no-mix-none" + (getArgs >>= shouldFail . sraMain . tixOnly) + , testCase "self-data-no-mix-one" + (do args <- getArgs + shouldFail (sraMain ((tixOnly args) {sra_mixs=["foo"]}))) + , testCase "self-data-no-all-two" + (do args <- getArgs + let args' = (tixOnly args) { sra_mixs = ["foo", "bar"] } + shouldFail (sraMain args')) + ] + where + tixOnly sra = emptySRA { sra_tix = sra_tix sra } + + -- ------------------------------------------------------------------------ -- +-- Discover tests +-- +-- ------------------------------------------------------------------------ + +discoverStackTest :: TestTree +discoverStackTest = + let t = buildAndTestWithStack + withProject name act = case getAcquireAndRelease Stack name [] of + (a,r) -> withResource a r (const act) + in testGroup "discover_stack" + [ t "project1" + [ "--root=" ++ testData "project1" + , "--verbose" + , "stack:project1-test"] + [] + , t "project1" + [ "--root=" ++ testData "project1" + , "--verbose" + , "--build=dot-stack-work" + , "stack:project1-test.tix"] + ["--work-dir=dot-stack-work"] + + , withProject "project1" $ + testCase "project1" $ + withCurrentDirectory (testData "project1") $ main' + [ "--verbose", "stack:project1-test" ] + + , withProject "project1" $ + withResource + (findUnder (\p -> takeFileName p == "project1-test.tix") + (testData "project1" ".stack-work")) + (\_ -> pure ()) + (\getTixPath -> testCase "project1" $ do + tix_path <- fromMaybe "project1-test.tix" <$> getTixPath + canonical_tix_path <- canonicalizePath tix_path + putStrLn $ + "tix_path: " ++ tix_path ++ "\n" ++ + "canonical_tix_path: " ++ canonical_tix_path + main' [ "--verbose", "stack:" ++ canonical_tix_path ]) + ] + +discoverCabalTest :: TestTree +discoverCabalTest = + let t = buildAndTestWithCabal + withProject name act = case getAcquireAndRelease Stack name [] of + (a,r) -> withResource a r (const act) + in testGroup "discover_cabal" + [ t "project1" + [ "--root=" ++ testData "project1" + , "--verbose" + , "-x", "Paths_project1" + , "-X", "project1-exe" + , "cabal:project1-test" ] + [] + + , withProject "project1" $ + withResource + (findUnder (\p -> takeFileName p == "project1-test.tix") + (testData "project1" "dist-newstyle")) + (\_ -> pure ()) + (\getTixPath -> testCase "project1" $ do + tix_path <- fromMaybe "project1-test.tix" <$> getTixPath + canonical_tix_path <- canonicalizePath tix_path + main' [ "--verbose" + , "-x", "Main,Paths_project1" + , "cabal:" ++ canonical_tix_path]) + ] + +buildAndTestWithStack :: String -> [String] -> [String] -> TestTree +buildAndTestWithStack = buildAndTestWith Stack + +buildAndTestWithCabal :: String -> [String] -> [String] -> TestTree +buildAndTestWithCabal = buildAndTestWith Cabal + +buildAndTestWith :: BuildTool -> String -> [String] -> [String] -> TestTree +buildAndTestWith tool name args tool_args = withResource acquire release work + where + (acquire, release) = getAcquireAndRelease tool name tool_args + work _ec = testCase name $ main' args + +getAcquireAndRelease + :: BuildTool -> String -> [String] -> (IO ExitCode, ExitCode -> IO ()) +getAcquireAndRelease tool name tool_args = (acquire, release) + where + dir = testData name + + acq_cmd = case tool of + Stack -> ("stack", ["test", "--coverage"]) + Cabal -> ("cabal", ["test", "--enable-coverage"]) + + call (cmd,args) = callProcessIn dir cmd (tool_args ++ args) + + acquire = do + putStrLn $ "Testing " ++ name ++ " with " ++ show tool ++ " ..." + ec <- call acq_cmd + putStrLn $ "ec: " ++ show ec + return ec + + release _ec = pure () + +callProcessIn :: FilePath -> String -> [String] -> IO ExitCode +callProcessIn dir cmd args = withCreateProcess cp f + where + f _ _ _ = waitForProcess + cp = (shell (unwords (cmd : args))) {cwd = Just dir} + + +-- ------------------------------------------------------------------------ +-- -- Auxiliary functions -- -- ------------------------------------------------------------------------ +isTestInTest :: IO Bool +isTestInTest = isJust <$> lookupEnv testInTestKey + +testInTestKey :: String +testInTestKey = "HPC_CODECOV_TEST_IN_TEST" + +findUnder :: (FilePath -> Bool) -> FilePath -> IO (Maybe FilePath) +findUnder test root = foldDir f Nothing [root] + where + f _ acc@(Just _) = return acc + f path Nothing = + if test path + then return (Just path) + else return Nothing + -- | Wrapper to run 'Trace.Hpc.Codecov.Main.main' with given argument -- strings. main' :: [String] -> IO () -main' args = withArgs args HpcCodecov.main +main' args = withArgs args HpcCodecov.defaultMain --- | 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) +sraMain :: SRA -> IO () +sraMain sra = main' args where - acquire = do extract testDataDir (testDataDir dot_tar) - return (testDataDir dropExtension dot_tar) - release = removeDirectoryRecursive + args = + map ("--mix=" ++) (sra_mixs sra) ++ + map ("--exclude=" ++) (sra_excludes sra) ++ + maybe [] (\p -> ["--out=" ++ p]) (sra_out sra) ++ + ["--verbose" | sra_verbose sra] ++ + [sra_tix sra] -- | Run test with path to temporary file. withTempFile :: (IO FilePath -> TestTree) -> TestTree @@ -131,27 +418,19 @@ 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" +withTempDir :: (IO FilePath -> TestTree) -> TestTree +withTempDir = withResource acquire release + where + acquire = do + mb_tool <- getBuildTool + dir <- case mb_tool of + Just Stack -> pure ".hpc_codecov_test_tmp_stack" + Just Cabal -> pure ".hpc_codecov_test_tmp_cabal_v2" + _ -> error "Cannot determine build tool" + exists <- doesDirectoryExist dir + when exists $ removeDirectoryRecursive dir + pure dir + release _ = return () -- | Pass the HUnit test when an exception was thrown, otherwise a -- test failure. @@ -159,5 +438,9 @@ shouldFail act = do et_err <- try act case et_err of - Left (SomeException {}) -> return () - _ -> assertFailure "should fail" + Left SomeException {} -> return () + _ -> assertFailure "should fail" + +-- | Get directory under test data. +testData :: String -> FilePath +testData dir = "test" "data" dir diff --git a/test/data/project1/ChangeLog.md b/test/data/project1/ChangeLog.md new file mode 100644 --- /dev/null +++ b/test/data/project1/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for project1 + +## Unreleased changes diff --git a/test/data/project1/LICENSE b/test/data/project1/LICENSE new file mode 100644 --- /dev/null +++ b/test/data/project1/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2021 + +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 Author name here 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/test/data/project1/README.md b/test/data/project1/README.md new file mode 100644 --- /dev/null +++ b/test/data/project1/README.md @@ -0,0 +1,1 @@ +# project1 diff --git a/test/data/project1/Setup.hs b/test/data/project1/Setup.hs new file mode 100644 --- /dev/null +++ b/test/data/project1/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/data/project1/app/Main.hs b/test/data/project1/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/data/project1/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = someFunc 42 diff --git a/test/data/project1/package.yaml b/test/data/project1/package.yaml new file mode 100644 --- /dev/null +++ b/test/data/project1/package.yaml @@ -0,0 +1,48 @@ +name: project1 +version: 0.1.0.0 +github: "githubuser/project1" +license: BSD3 +author: "Author name here" +maintainer: "example@example.com" +copyright: "2021 Author name here" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 + +library: + source-dirs: src + +executables: + project1-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - project1 + +tests: + project1-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - project1 diff --git a/test/data/project1/project1.cabal b/test/data/project1/project1.cabal new file mode 100644 --- /dev/null +++ b/test/data/project1/project1.cabal @@ -0,0 +1,62 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 2a82452cb1b1a322c856e7d346b38bfb8136930e2638507eb703234a0658f2dc + +name: project1 +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/project1#readme +bug-reports: https://github.com/githubuser/project1/issues +author: Author name here +maintainer: example@example.com +copyright: 2021 Author name here +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/githubuser/project1 + +library + exposed-modules: + Lib + other-modules: + Paths_project1 + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + default-language: Haskell2010 + +executable project1-exe + main-is: Main.hs + other-modules: + Paths_project1 + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , project1 + default-language: Haskell2010 + +test-suite project1-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_project1 + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , project1 + default-language: Haskell2010 diff --git a/test/data/project1/src/Lib.hs b/test/data/project1/src/Lib.hs new file mode 100644 --- /dev/null +++ b/test/data/project1/src/Lib.hs @@ -0,0 +1,9 @@ +module Lib + ( someFunc + ) where + +someFunc :: Int -> IO () +someFunc n = + if even n + then putStrLn "got even number" + else putStrLn "not a even number" diff --git a/test/data/project1/stack.yaml b/test/data/project1/stack.yaml new file mode 100644 --- /dev/null +++ b/test/data/project1/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# 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 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.5" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/data/project1/test/Spec.hs b/test/data/project1/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/data/project1/test/Spec.hs @@ -0,0 +1,4 @@ +import Lib + +main :: IO () +main = someFunc 42 diff --git a/test/data/reciprocal.tar b/test/data/reciprocal.tar deleted file mode 100644 Binary files a/test/data/reciprocal.tar and /dev/null differ diff --git a/test/data/reciprocal/.hpc/Main.mix b/test/data/reciprocal/.hpc/Main.mix new file mode 100644 --- /dev/null +++ b/test/data/reciprocal/.hpc/Main.mix @@ -0,0 +1,1 @@ +Mix "reciprocal.hs" 2020-02-05 11:44:49.181788328 UTC 2523442504 8 [(17:21-17:21,ExpBox False),(17:26-17:26,ExpBox False),(17:21-17:26,ExpBox False),(17:21-17:26,BinBox GuardBinBox True),(17:21-17:26,BinBox GuardBinBox False),(17:33-17:33,ExpBox True),(18:21-18:29,ExpBox False),(18:21-18:29,BinBox GuardBinBox True),(18:21-18:29,BinBox GuardBinBox False),(18:33-18:33,ExpBox False),(18:46-18:46,ExpBox False),(18:48-18:49,ExpBox False),(18:37-18:49,ExpBox False),(18:33-18:49,ExpBox True),(17:1-18:49,TopLevelBox ["position"]),(13:16-13:16,ExpBox False),(13:18-13:19,ExpBox False),(13:15-13:20,ExpBox False),(13:32-13:32,ExpBox False),(13:15-13:32,ExpBox False),(14:31-14:31,ExpBox False),(14:33-14:33,ExpBox False),(14:36-14:36,ExpBox False),(14:38-14:39,ExpBox False),(14:35-14:40,ExpBox False),(14:24-14:40,ExpBox False),(9:17-9:17,ExpBox False),(9:26-9:27,ExpBox False),(9:17-9:27,ExpBox False),(9:17-9:27,BinBox GuardBinBox True),(9:17-9:27,BinBox GuardBinBox False),(9:32-9:33,ExpBox False),(9:45-9:45,ExpBox False),(9:47-9:48,ExpBox False),(9:36-9:48,ExpBox False),(9:31-9:49,ExpBox True),(10:17-10:17,ExpBox False),(10:22-10:22,ExpBox False),(10:17-10:22,ExpBox False),(10:17-10:22,BinBox GuardBinBox True),(10:17-10:22,BinBox GuardBinBox False),(10:37-10:37,ExpBox False),(10:32-10:37,ExpBox False),(10:40-10:40,ExpBox False),(10:31-10:41,ExpBox True),(11:17-11:17,ExpBox False),(11:22-11:22,ExpBox False),(11:17-11:22,ExpBox False),(11:17-11:22,BinBox GuardBinBox True),(11:17-11:22,BinBox GuardBinBox False),(11:37-11:37,ExpBox False),(11:32-11:37,ExpBox False),(11:42-11:47,ExpBox False),(11:32-11:47,ExpBox False),(11:50-11:54,ExpBox False),(11:31-11:55,ExpBox True),(9:1-14:40,TopLevelBox ["divide"]),(6:30-6:30,ExpBox False),(6:32-6:32,ExpBox False),(6:34-6:35,ExpBox False),(6:23-6:35,ExpBox False),(2:16-2:16,ExpBox False),(2:20-2:20,ExpBox False),(2:16-2:20,ExpBox False),(2:16-2:20,BinBox GuardBinBox True),(2:16-2:20,BinBox GuardBinBox False),(2:25-2:27,ExpBox False),(2:31-2:33,ExpBox False),(2:37-2:42,ExpBox False),(2:31-2:42,ExpBox False),(2:25-2:42,ExpBox False),(2:45-2:49,ExpBox False),(2:24-2:50,ExpBox True),(3:16-3:24,ExpBox False),(3:16-3:24,BinBox GuardBinBox True),(3:16-3:24,BinBox GuardBinBox False),(4:18-4:66,ExpBox False),(3:28-4:66,ExpBox True),(2:1-6:35,TopLevelBox ["reciprocal"]),(26:25-26:25,ExpBox False),(26:14-26:25,ExpBox False),(25:16-25:16,ExpBox False),(25:9-25:16,ExpBox False),(25:20-25:20,ExpBox False),(25:9-25:20,ExpBox False),(25:5-25:20,LocalBox ["showRecip","p"]),(22:3-22:6,ExpBox False),(22:16-22:16,ExpBox False),(22:11-22:16,ExpBox False),(22:21-22:25,ExpBox False),(23:6-23:6,ExpBox False),(23:11-23:11,ExpBox False),(23:6-23:11,ExpBox False),(23:6-23:11,BinBox CondBinBox True),(23:6-23:11,BinBox CondBinBox False),(23:18-23:18,ExpBox True),(23:30-23:30,ExpBox False),(23:32-23:32,ExpBox False),(23:25-23:32,ExpBox False),(23:37-23:39,ExpBox False),(23:49-23:49,ExpBox False),(23:51-23:51,ExpBox False),(23:44-23:51,ExpBox False),(23:56-23:58,ExpBox False),(23:44-23:58,ExpBox False),(23:37-23:58,ExpBox False),(23:25-23:58,ExpBox True),(23:3-23:58,ExpBox False),(22:21-23:58,ExpBox False),(22:11-23:58,ExpBox False),(22:3-23:58,ExpBox False),(21:1-26:25,TopLevelBox ["showRecip"]),(29:8-29:13,ExpBox False),(30:23-30:23,ExpBox False),(30:12-30:24,ExpBox False),(30:3-30:24,ExpBox False),(31:3-31:6,ExpBox False),(28:8-31:6,ExpBox False),(28:1-31:6,TopLevelBox ["main"])] diff --git a/test/data/reciprocal/reciprocal.hs b/test/data/reciprocal/reciprocal.hs new file mode 100644 --- /dev/null +++ b/test/data/reciprocal/reciprocal.hs @@ -0,0 +1,31 @@ +reciprocal :: Int -> (String, Int) +reciprocal n | n > 1 = ('0' : '.' : digits, recur) + | otherwise = error + "attempting to compute reciprocal of number <= 1" + where + (digits, recur) = divide n 1 [] + +divide :: Int -> Int -> [Int] -> (String, Int) +divide n c cs | c `elem` cs = ([], position c cs) + | r == 0 = (show q, 0) + | r /= 0 = (show q ++ digits, recur) + where + (q, r) = (c*10) `quotRem` n + (digits, recur) = divide n r (c:cs) + +position :: Int -> [Int] -> Int +position n (x:xs) | n == x = 1 + | otherwise = 1 + position n xs + +showRecip :: Int -> String +showRecip n = + "1/" ++ show n ++ " = " ++ + if r == 0 then d else take p d ++ "(" ++ drop p d ++ ")" + where + p = length d - r + (d, r) = reciprocal n + +main = do + n <- readLn + putStrLn (showRecip n) + main diff --git a/test/data/reciprocal/reciprocal.tix b/test/data/reciprocal/reciprocal.tix new file mode 100644 --- /dev/null +++ b/test/data/reciprocal/reciprocal.tix @@ -0,0 +1,1 @@ +Tix [ TixModule "Main" 2523442504 119 [6,6,6,1,5,1,5,5,0,5,5,5,5,5,6,6,6,6,6,6,5,6,6,6,6,6,6,7,7,1,6,1,1,1,1,1,6,6,6,0,6,0,0,0,0,6,6,6,6,0,6,6,6,6,6,6,7,1,1,1,1,1,1,1,1,0,1,1,1,1,1,1,1,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1]] diff --git a/test/data/self.tar b/test/data/self.tar deleted file mode 100644 Binary files a/test/data/self.tar and /dev/null differ