Add stack support

hpc-coveralls.cabal

@@ -54,7 +54,8 @@ library
     Trace.Hpc.Coveralls.Config,
     Trace.Hpc.Coveralls.Curl,
     Trace.Hpc.Coveralls.GitInfo,
-    Trace.Hpc.Coveralls.Paths
+    Trace.Hpc.Coveralls.Paths,
+    Trace.Hpc.Coveralls.Stack
   build-depends:
     aeson          >= 0.7.1   && <1.3,
     base           >= 4       && < 5,
@@ -71,7 +72,8 @@ library
     retry          >= 0.5     && <0.8,
     safe           >= 0.3     && <0.4,
     split          >= 0.2.2   && <0.3,
-    transformers   >= 0.4.1   && <0.6
+    transformers   >= 0.4.1   && <0.6,
+    filepath       >= 1.4.1.1 && <1.5
 
 executable hpc-coveralls
   hs-source-dirs: src
@@ -92,7 +94,8 @@ executable hpc-coveralls
     retry          >= 0.5     && <0.8,
     safe           >= 0.3     && <0.4,
     split          >= 0.2.2   && <0.3,
-    transformers   >= 0.4.1   && <0.6
+    transformers   >= 0.4.1   && <0.6,
+    filepath       >= 1.4.1.1 && <1.5
   ghc-options:    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
 
 executable run-cabal-test

src/HpcCoverallsCmdLine.hs

@@ -12,6 +12,8 @@ data HpcCoverallsArgs = CmdMain
     { optExcludeDirs   :: [String]
     , argTestSuites    :: [String]
     , optCabalFile     :: Maybe String
+    , optHpcDirPath    :: Maybe String
+    , optUseStackCov   :: Bool
     , optServiceName   :: Maybe String
     , optRepoToken     :: Maybe String
     , optDisplayReport :: Bool
@@ -28,6 +30,8 @@ hpcCoverallsArgs = CmdMain
     , optDontSend      = False             &= explicit                &= name "dont-send"      &= help "Do not send the report to coveralls.io"
     , optCoverageMode  = AllowPartialLines &= explicit &= typ "MODE"  &= name "coverage-mode"  &= help "Coverage conversion mode: AllowPartialLines (default), StrictlyFullLines"
     , optCabalFile     = Nothing           &= explicit &= typ "FILE"  &= name "cabal-file"     &= help "Cabal file (ex.: module-name.cabal)"
+    , optHpcDirPath    = Nothing           &= explicit &= typ "DIR"   &= name "hpc-dir"        &= help "Hpc dir (ex.: dist/hpc/)"
+    , optUseStackCov   = False             &= explicit                &= name "use-stack-cov"  &= help "Use the stack coverage report"
     , 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"
     , argTestSuites    = []                &= typ "TEST-SUITES" &= args

src/HpcCoverallsMain.hs

@@ -1,6 +1,5 @@
 module Main where
 
-import           Control.Applicative
 import           Control.Concurrent
 import           Control.Monad
 import           Data.Aeson
@@ -44,6 +43,8 @@ getConfig hca = Config
     (optExcludeDirs hca)
     (optCoverageMode hca)
     (optCabalFile hca)
+    (optHpcDirPath hca)
+    (optUseStackCov hca)
     (optServiceName hca)
     (optRepoToken hca)
     <$> listToMaybe (argTestSuites hca)

src/Trace/Hpc/Coveralls.hs

@@ -11,9 +11,7 @@
 
 module Trace.Hpc.Coveralls ( generateCoverallsFromTix ) where
 
-import           Control.Applicative
 import           Data.Aeson
-import           Data.Aeson.Types ()
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import           Data.Digest.Pure.MD5
 import           Data.Function
@@ -104,21 +102,26 @@ mergeModuleCoverageData (source, mix, tixs1) (_, _, tixs2) =
 mergeCoverageData :: [TestSuiteCoverageData] -> TestSuiteCoverageData
 mergeCoverageData = foldr1 (M.unionWith mergeModuleCoverageData)
 
-readMix' :: Maybe String -> String -> String -> TixModule -> IO Mix
+readMix' :: Maybe String -> HpcDir -> String -> TixModule -> IO Mix
 readMix' mPkgNameVer hpcDir name tix = readMix dirs (Right tix)
-    where dirs = nub $ (\x -> getMixPath x hpcDir name tix) <$> [Nothing, mPkgNameVer]
+    where dirs = nub $ (\x -> getMixDirPath x hpcDir name tix) <$> [Nothing, mPkgNameVer]
 
 -- | Create a list of coverage data from the tix input
 readCoverageData :: Maybe String             -- ^ Package name-version
-                 -> String                   -- ^ hpc data directory
+                 -> HpcDir                   -- ^ hpc data directory
                  -> [String]                 -- ^ excluded source folders
                  -> String                   -- ^ test suite name
                  -> IO TestSuiteCoverageData -- ^ coverage data list
 readCoverageData mPkgNameVer hpcDir excludeDirPatterns testSuiteName = do
-    let tixPath = getTixPath hpcDir testSuiteName
+    let tixPath = getTixFilePath hpcDir testSuiteName
     mTix <- readTix tixPath
+
     case mTix of
-        Nothing -> putStrLn ("Couldn't find the file " ++ tixPath) >> dumpDirectoryTree hpcDir >> ioFailure
+        Nothing -> do
+            putStrLn $ "Couldn't find the file " ++ tixPath
+            dumpDirectoryTree $ tixDir hpcDir
+            ioFailure
+
         Just (Tix tixs) -> do
             mixs <- mapM (readMix' mPkgNameVer hpcDir testSuiteName) tixs
             let files = map filePath mixs
@@ -137,19 +140,24 @@ generateCoverallsFromTix :: String       -- ^ CI name
                          -> Maybe String -- ^ Package name-version
                          -> IO Value     -- ^ code coverage result in json format
 generateCoverallsFromTix serviceName jobId gitInfo config mPkgNameVer = do
-    mHpcDir <- firstExistingDirectory hpcDirs
+    mHpcDir <- getHpcDir config
     case mHpcDir of
-        Nothing -> putStrLn "Couldn't find the hpc data directory" >> dumpDirectory distDir >> ioFailure
-        Just hpcDir -> do
+        Left msg -> do
+            putStrLn "Couldn't find the hpc data directory"
+            putStrLn $ "Error: " ++ msg
+            ioFailure
+
+        Right hpcDir -> do
             testSuitesCoverages <- mapM (readCoverageData mPkgNameVer hpcDir excludedDirPatterns) testSuiteNames
             let coverageData = mergeCoverageData testSuitesCoverages
-            return $ toCoverallsJson serviceName jobId repoTokenM gitInfo converter coverageData
-            where excludedDirPatterns = excludedDirs config
-                  testSuiteNames = testSuites config
-                  repoTokenM = repoToken config
-                  converter = case coverageMode config of
-                      StrictlyFullLines -> strictConverter
-                      AllowPartialLines -> looseConverter
+            return $ toCoverallsJson serviceName jobId mRepoToken gitInfo converter coverageData
+    where
+        excludedDirPatterns = excludedDirs config
+        testSuiteNames = testSuites config
+        mRepoToken = repoToken config
+        converter = case coverageMode config of
+            StrictlyFullLines -> strictConverter
+            AllowPartialLines -> looseConverter
 
 ioFailure :: IO a
 ioFailure = putStrLn ("You can get support at " ++ gitterUrl) >> exitFailure

src/Trace/Hpc/Coveralls/Config.hs

@@ -6,6 +6,8 @@ data Config = Config {
     excludedDirs :: ![FilePath],
     coverageMode :: !CoverageMode,
     cabalFile    :: !(Maybe FilePath),
+    hpcDirPath   :: !(Maybe FilePath),
+    useStackCov  :: !Bool,
     serviceName  :: !(Maybe String),
     repoToken    :: !(Maybe String),
     testSuites   :: ![String]

src/Trace/Hpc/Coveralls/Paths.hs

@@ -11,42 +11,85 @@
 
 module Trace.Hpc.Coveralls.Paths where
 
-import Control.Monad
-import Data.Maybe
-import Data.Traversable (traverse)
-import System.Directory (
-    doesDirectoryExist, getDirectoryContents
-    )
-import System.Directory.Tree (
-    AnchoredDirTree(..), dirTree, readDirectoryWith
-    )
-import Trace.Hpc.Tix
-
-distDir :: FilePath
-distDir = "dist/"
-
-hpcDirs :: [FilePath]
-hpcDirs = map (distDir ++) ["hpc/vanilla/", "hpc/"]
-
-tixDir :: String -> FilePath
-tixDir = (++ "tix/")
-
-mixDir :: String -> FilePath
-mixDir = (++ "mix/")
-
-getMixPath :: Maybe String -- ^ target package name-version
-           -> String       -- ^ hpc output base directory
-           -> String       -- ^ test suite name
-           -> TixModule    -- ^ tix module
-           -> FilePath     -- ^ mix file path
-getMixPath mPkgNameVer hpcDir testSuiteName tix = mixDir hpcDir ++ dirName ++ "/"
-    where dirName = case span (/= '/') modName of
-              (_, []) -> testSuiteName
+import           Control.Monad
+import           Data.Maybe                 (fromMaybe)
+import           Data.Traversable           (traverse)
+import           System.Directory           (doesDirectoryExist,
+                                             getDirectoryContents)
+import           System.Directory.Tree      (AnchoredDirTree (..), dirTree,
+                                             readDirectoryWith)
+import           System.FilePath
+import           Trace.Hpc.Coveralls.Config
+import           Trace.Hpc.Coveralls.Stack
+import           Trace.Hpc.Tix
+
+data HpcDir = HpcDir
+  { tixDir        :: !FilePath
+  , mixDir        :: !FilePath
+  , isStackHpcDir :: !Bool
+  } deriving (Show, Eq)
+
+getHpcDir :: Config -> IO (Either String HpcDir)
+getHpcDir config
+    | useStackCov config = stackHpcDir
+getHpcDir config = case hpcDirPath config of
+    Just hpcDir -> buildHpcDir hpcDir
+    Nothing     -> getHpcDir'
+    where
+        getHpcDir' = do
+            mPath <- firstExistingDirectory cabalHpcDirs
+            maybe stackHpcDir buildHpcDir mPath
+
+cabalDistDir :: FilePath
+cabalDistDir = "dist/"
+
+cabalHpcDirs :: [FilePath]
+cabalHpcDirs = map (cabalDistDir ++) ["hpc/vanilla/", "hpc/"]
+
+stackHpcDir :: IO (Either String HpcDir)
+stackHpcDir = do
+    canExecStack <- checkStackVersion
+    if canExecStack
+        then Right <$> getStackHpcDir
+        else return $ Left "cannot exec `stack`"
+
+getStackHpcDir :: IO HpcDir
+getStackHpcDir = HpcDir
+    <$> ((</>) <$> stackHpcRootPath <*> stackProjectName)
+    <*> stackDistHpcRootPath
+    <*> pure True
+
+buildHpcDir :: FilePath -> IO (Either String HpcDir)
+buildHpcDir hpcDir = do
+    mTixDir <- firstExistingDirectory [hpcDir </> "tix", hpcDir]
+    let eTixDir = maybe (Left $ "not found: " ++ hpcDir </> "tix") Right mTixDir
+
+    mMixDir <- firstExistingDirectory [hpcDir </> "mix", hpcDir]
+    let eMixDir = maybe (Left $ "not found: " ++ hpcDir </> "mix") Right mMixDir
+
+    return $ HpcDir <$> eTixDir <*> eMixDir <*> pure False
+
+getMixDirPath :: Maybe String -- ^ target package name-version
+              -> HpcDir       -- ^ hpc output base directory
+              -> String       -- ^ test suite name
+              -> TixModule    -- ^ tix module
+              -> FilePath     -- ^ mix file path
+getMixDirPath _ hpcDir _ _ = mixDir hpcDir
+getMixDirPath mPkgNameVer hpcDir testSuiteName tix
+    =   mixDir hpcDir
+    </> dirName
+    where
+        dirName = case span (/= '/') modName of
+              (_, [])        -> testSuiteName
               (packageId, _) -> fromMaybe packageId mPkgNameVer
-          TixModule modName _ _ _ = tix
 
-getTixPath :: String -> String -> FilePath
-getTixPath hpcDir testSuiteName = tixDir hpcDir ++ testSuiteName ++ "/" ++ getTixFileName testSuiteName
+        TixModule modName _ _ _ = tix
+
+getTixFilePath :: HpcDir -> String -> FilePath
+getTixFilePath hpcDir testSuiteName
+    =   tixDir hpcDir
+    </> testSuiteName
+    </> getTixFileName testSuiteName
 
 firstExistingDirectory :: [FilePath] -> IO (Maybe FilePath)
 firstExistingDirectory = fmap msum . mapM pathIfExist

src/Trace/Hpc/Coveralls/Stack.hs

@@ -0,0 +1,38 @@
+module Trace.Hpc.Coveralls.Stack
+    ( checkStackVersion
+    , stackProjectName
+    , stackPath
+    , stackHpcRootPath
+    , stackDistHpcRootPath
+    ) where
+
+import           Control.Exception
+import           System.FilePath
+import           System.IO.Error
+import           System.Process           (callProcess, readProcess)
+import           Trace.Hpc.Coveralls.Util
+
+checkStackVersion :: IO Bool
+checkStackVersion = handle (handleIOError False) $ do
+    callProcess "stack" ["--version"]
+    return True
+    where
+        handleIOError :: a -> IOError -> IO a
+        handleIOError d e
+            | isDoesNotExistError e = return d
+        handleIOError _ e = throwIO e
+
+stackPath :: String -> IO FilePath
+stackPath key = stripString <$> readProcess "stack" ["path", "--" ++ key] ""
+
+stackProjectName :: IO String
+stackProjectName = takeFileName <$> stackPath "project-root"
+
+stackHpcRootPath :: IO FilePath
+stackHpcRootPath = stackPath "local-hpc-root"
+
+stackDistDirPath :: IO FilePath
+stackDistDirPath = stackPath "dist-dir"
+
+stackDistHpcRootPath :: IO FilePath
+stackDistHpcRootPath = (</> "hpc") <$> stackDistDirPath

src/Trace/Hpc/Coveralls/Util.hs

@@ -10,6 +10,7 @@
 module Trace.Hpc.Coveralls.Util where
 
 import Data.List
+import Data.Char
 
 fst3 :: (a, b, c) -> a
 fst3 (x, _, _) = x
@@ -58,3 +59,6 @@ groupByIndex size = take size . flip (++) (repeat []) . groupByIndex' 0 []
           groupByIndex' i ys xx@((xi, x) : xs) = if xi == i
               then groupByIndex' i (x : ys) xs
               else ys : groupByIndex' (i + 1) [] xx
+
+stripString :: String -> String
+stripString = takeWhile (not . isSpace) . dropWhile isSpace

test/TestHpcCoverallsUtil.hs

@@ -79,9 +79,14 @@ testGroupByIndex = "groupByIndex" ~: [
     groupByIndex 3 [(1, 2), (1, 3)] @?= [[], [3, 2], []],
     groupByIndex 5 [(0, 2), (2, 5), (2, 3), (4, 13), (4, 11), (4, 7)] @?= [[2], [], [3, 5], [], [7, 11, 13]]]
 
+testStripString = "stripString" ~: [
+    stripString " aa " @?= "aa",
+    stripString "\nbb" @?= "bb"]
+
 testUtil = "Util" ~: [
     testMapFirst,
     testMapLast,
     testSubSeq,
     testSubSubSeq,
-    testGroupByIndex]
+    testGroupByIndex,
+    testStripString]