Support cabal.projects

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 <guillaume+hackage@nargeot.com>
+-- 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