Support cabal.projects

- Allow user to specify "package directories" corresponding to the
  source directories of packages in a cabal.project.
- Add functionality required to allow the user to specify the hpc data
  search directories explicitly, rather than searching for it in the
  usual places. This is primarily motivated by the Nix package
  manager, where hpc output is usally written to some folder outside
  of the current directory (e.g. to
  /nix/store/HASH-my-lib-0.1.0.0/share/hpc) as well as cabal.projects,
  where the hpc output directory might be
  "dist-newstyle/build/$platform/$compiler/$package/hpc". Multiple hpc
  directories can be specified, for e.g., one for each package in a
  cabal.project.
- The filepath listed in a mix file doesn't include the sub-directory
  of the package in a cabal.project. So for cabal.projects, the
  filepath used as the index in the TestSuiteCoverageData is now
  prefixed with the sub-directory of the package. The behaviour when
  not using the "--package-dir" argument, or when using "--package-dir
  ./" is unchanged.
- Gave a Monoid instance to TestSuiteCoverageData so we can easily use
  folds to sum the data up.
- Separated the coveralls.io specific logic and the coverage data
  logic. The coverage data could be re-used for other coveralls-style
  tools.
- Source files are now excluded before searching for them, so that if
  the file does not exist, it does not throw an error (primarily
  motivated by out-of-source builds such as Nix, where modules such as
  Path_library.hs can't be found in the build directory).
- Changed the structure of getCoverageData a little, and added some
  commentary, so each of the steps required to read all the coverage
  data are a bit clearer.

README.md

@@ -151,6 +151,56 @@ You will have to specify it for example when using Travis-pro as in the example
 --service-name=travis-pro
 ```
 
+#### --hpc-dir
+
+This option allows you to manually specify a number of directories to search for hpc output. The behaviour without this option is to attempt to find the hpc data in the typical places in the current directory.
+```bash
+--hpc-dir=/dir/share/hpc
+```
+
+This directory should contain your hpc data (mix files and tix files) in the standard directory structure for hpc output, for example:
+
+```bash
+hpc
+├── mix
+│   ├── my-lib-0.1.0.0
+│   │   └── my-lib-0.1.0.0-inplace
+│   │       ├── My.Lib.A.mix
+│   │       ├── My.Lib.B.mix
+│   |       └── My.Lib.C.mix
+│   ├── my-lib-test
+│   │   ├── SomeSpec.mix
+│   │   ├── SomeOtherSpec.mix
+│       └── Main.mix
+│   └── my-lib-test2
+│       ├── SomeSpec2.mix
+│       ├── SomeOtherSpec2.mix
+│       └── Main.mix
+└── tix
+    ├── my-lib-0.1.0.0
+    │   └── my-lib-0.1.0.0.tix
+    ├── my-lib-test
+    │   └── my-lib-test.tix
+    └── my-lib-test2
+        └── my-lib-test2.tix
+```
+
+When using hpc-coveralls with a cabal.project, your invocation will probably include:
+```bash
+--hpc-dir ./dist-newstyle/build/x86_64-linux/ghc-8.6.5/my-package1 --hpc-dir ./dist-newstyle/build/x86_64-linux/ghc-8.6.5/my-package2
+```
+
+hpc-coveralls is not yet smart enough to discover these directories for you.
+
+### --package-dir
+
+This option allows you to specify a number of directories to search for cabal and source files. This might, for example, be used in a "cabal.project" with multiple Haskell packages.
+
+It will only be used if `--cabal-file` is not used.
+```bash
+--package-dir ./my-lib-1 --package-dir ./my-lib-2
+```
+
 # Limitations
 
 Because of the way hpc works, coverage data is only generated for modules that are referenced directly or indirectly by the test suites.

hpc-coveralls.cabal

@@ -44,6 +44,7 @@ library
   hs-source-dirs: src
   exposed-modules:
     Trace.Hpc.Coveralls,
+    Trace.Hpc.Coverage,
     Trace.Hpc.Coveralls.Lix,
     Trace.Hpc.Coveralls.Types,
     Trace.Hpc.Coveralls.Util

src/HpcCoverallsCmdLine.hs

@@ -18,6 +18,8 @@ data HpcCoverallsArgs = CmdMain
     , optCurlVerbose   :: Bool
     , optDontSend      :: Bool
     , optCoverageMode  :: CoverageMode
+    , optHpcDirs       :: [String]
+    , optPackageDirs   :: [String]
     } deriving (Data, Show, Typeable)
 
 hpcCoverallsArgs :: HpcCoverallsArgs
@@ -30,6 +32,8 @@ hpcCoverallsArgs = CmdMain
     , optCabalFile     = Nothing           &= explicit &= typ "FILE"  &= name "cabal-file"     &= help "Cabal file (ex.: module-name.cabal)"
     , optServiceName   = Nothing           &= explicit &= typ "TOKEN" &= name "service-name"   &= help "service-name (e.g. travis-pro)"
     , optRepoToken     = Nothing           &= explicit &= typ "TOKEN" &= name "repo-token"     &= help "Coveralls repo token"
+    , optHpcDirs       = []                &= explicit &= typDir      &= name "hpc-dir"        &= help "Explicitly use these hpc directories instead of trying to discover one"
+    , optPackageDirs   = []                &= explicit &= typDir      &= name "package-dir"    &= help "If building a project with multiple packages, or if your source is not in the current directory, specify package sub-directories here. This will only be used if the cabal-file option is not specified"
     , argTestSuites    = []                &= typ "TEST-SUITES" &= args
     } &= summary ("hpc-coveralls v" ++ versionString version ++ ", (C) Guillaume Nargeot 2014-2015")
       &= program "hpc-coveralls"

src/HpcCoverallsMain.hs

@@ -12,11 +12,12 @@ import           System.Console.CmdArgs
 import           System.Environment (getEnv, getEnvironment)
 import           System.Exit (exitFailure)
 import           Trace.Hpc.Coveralls
-import           Trace.Hpc.Coveralls.Cabal
-import           Trace.Hpc.Coveralls.Config (Config(Config, cabalFile, serviceName))
+import           Trace.Hpc.Coverage
+import           Trace.Hpc.Coveralls.Config (Config(Config, serviceName, excludedDirs, repoToken, coverageMode))
 import           Trace.Hpc.Coveralls.Curl
 import           Trace.Hpc.Coveralls.GitInfo (getGitInfo)
 import           Trace.Hpc.Coveralls.Util
+import           Trace.Hpc.Coveralls.Types
 
 urlApiV1 :: String
 urlApiV1 = "https://coveralls.io/api/v1/jobs"
@@ -39,45 +40,55 @@ getServiceAndJobID = do
 writeJson :: String -> Value -> IO ()
 writeJson filePath = BSL.writeFile filePath . encode
 
-getConfig :: HpcCoverallsArgs -> Maybe Config
+getConfig :: HpcCoverallsArgs -> Config
 getConfig hca = Config
     (optExcludeDirs hca)
     (optCoverageMode hca)
     (optCabalFile hca)
     (optServiceName hca)
     (optRepoToken hca)
-    <$> listToMaybe (argTestSuites hca)
+    (optHpcDirs hca)
+    (optPackageDirs hca)
+    (argTestSuites hca)
 
 main :: IO ()
 main = do
-    hca <- cmdArgs hpcCoverallsArgs
-    case getConfig hca of
-        Nothing -> putStrLn "Please specify a target test suite name"
-        Just config -> do
-            (defaultServiceName, jobId) <- getServiceAndJobID
-            let sn = fromMaybe defaultServiceName (serviceName config)
-            gitInfo <- getGitInfo
-            mPkgNameVer <- case cabalFile config of
-                Just cabalFilePath -> getPackageNameVersion cabalFilePath
-                Nothing -> currDirPkgNameVer
-            gitInfo <- getGitInfo
-            coverallsJson <- generateCoverallsFromTix sn jobId gitInfo config mPkgNameVer
-            when (optDisplayReport hca) $ BSL.putStrLn $ encode coverallsJson
-            let filePath = sn ++ "-" ++ jobId ++ ".json"
-            writeJson filePath coverallsJson
-            unless (optDontSend hca) $ do
-                response <- postJson filePath urlApiV1 (optCurlVerbose hca)
-                case response of
-                    PostSuccess url -> do
-                        putStrLn ("URL: " ++ url)
-                        -- wait 10 seconds until the page is available
-                        threadDelay (10 * 1000 * 1000)
-                        coverageResult <- readCoverageResult url (optCurlVerbose hca)
-                        case coverageResult of
-                            Just totalCoverage -> putStrLn ("Coverage: " ++ totalCoverage)
-                            Nothing -> putStrLn "Failed to read total coverage"
-                    PostFailure msg -> do
-                        putStrLn ("Error: " ++ msg)
-                        putStrLn ("You can get support at " ++ gitterUrl)
-                        exitFailure
-                        where gitterUrl = "https://gitter.im/guillaume-nargeot/hpc-coveralls"
+  hca <- cmdArgs hpcCoverallsArgs
+  let config = getConfig hca
+
+  hpcDirs        <- findHpcDataDirs config
+  pkgs           <- findPackages config
+  testSuiteNames <- findTestSuiteNames config pkgs
+  coverageData   <- getCoverageData pkgs hpcDirs (excludedDirs config) testSuiteNames
+
+  (defaultServiceName, jobId) <- getServiceAndJobID
+  let sn = fromMaybe defaultServiceName (serviceName config)
+  gitInfo <- getGitInfo
+
+  let
+    repoTokenM = repoToken config
+    converter = case coverageMode config of
+      StrictlyFullLines -> strictConverter
+      AllowPartialLines -> looseConverter
+    coverallsJson = toCoverallsJson sn jobId repoTokenM gitInfo converter coverageData
+
+  when (optDisplayReport hca) $ BSL.putStrLn $ encode coverallsJson
+
+  let filePath = sn ++ "-" ++ jobId ++ ".json"
+  writeJson filePath coverallsJson
+  unless (optDontSend hca) $ do
+      response <- postJson filePath urlApiV1 (optCurlVerbose hca)
+      case response of
+          PostSuccess url -> do
+              putStrLn ("URL: " ++ url)
+              -- wait 10 seconds until the page is available
+              threadDelay (10 * 1000 * 1000)
+              coverageResult <- readCoverageResult url (optCurlVerbose hca)
+              case coverageResult of
+                  Just totalCoverage -> putStrLn ("Coverage: " ++ totalCoverage)
+                  Nothing -> putStrLn "Failed to read total coverage"
+          PostFailure msg -> do
+              putStrLn ("Error: " ++ msg)
+              putStrLn ("You can get support at " ++ gitterUrl)
+              exitFailure
+              where gitterUrl = "https://gitter.im/guillaume-nargeot/hpc-coveralls"

src/Trace/Hpc/Coverage.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module:      Trace.Hpc.Coveralls
+-- Copyright:   (c) 2014-2015 Guillaume Nargeot
+-- License:     BSD3
+-- Maintainer:  Guillaume Nargeot <[email protected]>
+-- Stability:   experimental
+--
+-- Functions for collection hpc data.
+
+module Trace.Hpc.Coverage ( getCoverageData ) where
+
+import           Control.Applicative
+import           Data.List
+import           Data.Maybe (fromMaybe)
+import           Data.Semigroup ((<>))
+import qualified Data.Map.Strict as M
+import           System.Directory (findFile)
+import           Trace.Hpc.Coveralls.Paths
+import           Trace.Hpc.Coveralls.Types
+import           Trace.Hpc.Coveralls.Util
+import           Trace.Hpc.Mix
+import           Trace.Hpc.Tix
+
+readMix' :: [PackageIdentifier] -> [FilePath] -> String -> TixModule -> IO Mix
+readMix' pkgIds hpcDirs name tix = readMix dirs (Right tix)
+    where
+      dirs        = nub $ (\p hpcDir -> getMixPath p hpcDir name tix) <$> (Nothing : (Just <$> pkgNameVers)) <*> hpcDirs
+      pkgNameVers = asNameVer <$> pkgIds
+
+readTix' :: [FilePath]
+         -- ^ HPC data directories
+         -> String
+         -- ^ Test suite name
+         -> IO Tix
+         -- ^ Tix
+readTix' hpcDirs testSuiteName = do
+  let tixFileLocations = possibleTixFileLocations hpcDirs testSuiteName
+  mTixPath <- firstExistingFile tixFileLocations
+
+  case mTixPath of
+    Nothing      ->
+      putStrLn ("Couldn't find any of the possible tix file locations: " ++ show tixFileLocations) >> ioFailure
+    Just tixPath -> do
+      mTix <- readTix tixPath
+      case mTix of
+          Nothing         ->
+            putStrLn ("Couldn't read the file " ++ tixPath) >> ioFailure
+          Just tix -> pure tix
+
+getCoverageData
+  :: [Package]
+  -- ^ Packages
+  -> [FilePath]
+  -- ^ HPC data directories
+  -> [String]
+  -- ^ Excluded source folders
+  -> [String]
+  -- ^ Test suite names
+  -> IO TestSuiteCoverageData
+getCoverageData pkgs hpcDirs excludedDirPatterns testSuiteNames = do
+  -- For each test suite
+  foldFor testSuiteNames $ \testSuiteName -> do
+
+    -- Read the tix file for the test suite
+    (Tix tixModules) <- readTix' hpcDirs testSuiteName
+
+    -- For each TixModule in the tix file
+    foldFor tixModules $ \tixModule@(TixModule _ _ _ tixs) -> do
+
+      -- Read the mix file
+      mix@(Mix filePath _ _ _ _) <- readMix' pkgIds hpcDirs testSuiteName tixModule
+
+      -- Also read the source associated with the mix file, but only if it's not excluded
+      if matchAny excludedDirPatterns filePath
+        then mempty -- If excluded, we just return monoidal identity
+        else do
+          -- Find source relative to project sub-directory (e.g. "./", "./my-lib-01")
+          projectFilePath <- findProjectSourceFile pkgDirs filePath
+          source          <- readFile projectFilePath
+
+          -- Package source up with module mix and tix information, indexed by the file path.
+          pure . TestSuiteCoverageData $ M.singleton projectFilePath (source, mix, tixs)
+
+          -- Sum all this up using the Monoid instance for TestCoverageData.
+
+  where
+    pkgIds  = pkgId <$> pkgs
+    pkgDirs = pkgRootDir <$> pkgs
+
+findProjectSourceFile :: [FilePath] -> FilePath -> IO FilePath
+findProjectSourceFile pkgDirs fp = do
+  mFile <- findFile pkgDirs fp
+  case mFile of
+    Nothing ->
+      putStrLn ("Couldn't find the source file " ++ fp ++ " in directories: " <> show pkgDirs <> ".") >> ioFailure
+    (Just actualFilePath) ->
+      pure (removeLeading "./" $ -- To retain consistency with current reports
+            actualFilePath)
+  where
+    -- Remove prefix from a string (if present, do nothing otherwise)
+    removeLeading :: String -> String -> String
+    removeLeading prefix path = fromMaybe path $ stripPrefix prefix path