Add stack support

README.md

@@ -151,6 +151,18 @@ You will have to specify it for example when using Travis-pro as in the example
 --service-name=travis-pro
 ```
 
+#### --tix-dir
+
+Use this option to specify the tix directory for searching tix files.
+
+#### --mix-dir
+
+Use this option to specify the mix directory for searching mix files.
+
+#### --use-stack-cov
+
+The boolean option specifies to use stack coverage reports.
+
 # 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

@@ -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,9 @@ data HpcCoverallsArgs = CmdMain
     { optExcludeDirs   :: [String]
     , argTestSuites    :: [String]
     , optCabalFile     :: Maybe String
+    , optTixDirPath    :: Maybe String
+    , optMixDirPath    :: Maybe String
+    , optUseStackCov   :: Bool
     , optServiceName   :: Maybe String
     , optRepoToken     :: Maybe String
     , optDisplayReport :: Bool
@@ -28,6 +31,9 @@ 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)"
+    , optTixDirPath    = Nothing           &= explicit &= typDir      &= name "tix-dir"        &= help "Tix dir (ex.: dist/hpc/tix/)"
+    , optMixDirPath    = Nothing           &= explicit &= typDir      &= name "mix-dir"        &= help "Mix dir (ex.: dist/hpc/mix/)"
+    , 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

@@ -44,6 +44,9 @@ getConfig hca = Config
     (optExcludeDirs hca)
     (optCoverageMode hca)
     (optCabalFile hca)
+    (optMixDirPath hca)
+    (optTixDirPath hca)
+    (optUseStackCov hca)
     (optServiceName hca)
     (optRepoToken hca)
     <$> listToMaybe (argTestSuites hca)

src/Trace/Hpc/Coveralls.hs

@@ -13,7 +13,6 @@ 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 +103,25 @@ mergeModuleCoverageData (source, mix, tixs1) (_, _, tixs2) =
 mergeCoverageData :: [TestSuiteCoverageData] -> TestSuiteCoverageData
 mergeCoverageData = foldr1 (M.unionWith mergeModuleCoverageData)
 
-readMix' :: Maybe String -> String -> String -> TixModule -> IO Mix
-readMix' mPkgNameVer hpcDir name tix = readMix dirs (Right tix)
-    where dirs = nub $ (\x -> getMixPath x hpcDir name tix) <$> [Nothing, mPkgNameVer]
+readMix' :: Maybe String -> HpcDir -> String -> TixModule -> IO Mix
+readMix' mPkgNameVer hpcDir name tix = readMix (getMixDirPaths mPkgNameVer hpcDir name tix) (Right tix)
 
 -- | 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,9 @@ data Config = Config {
     excludedDirs :: ![FilePath],
     coverageMode :: !CoverageMode,
     cabalFile    :: !(Maybe FilePath),
+    mixDirPath   :: !(Maybe FilePath),
+    tixDirPath   :: !(Maybe FilePath),
+    useStackCov  :: !Bool,
     serviceName  :: !(Maybe String),
     repoToken    :: !(Maybe String),
     testSuites   :: ![String]

src/Trace/Hpc/Coveralls/Paths.hs

@@ -11,42 +11,97 @@
 
 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
-              (packageId, _) -> fromMaybe packageId mPkgNameVer
-          TixModule modName _ _ _ = tix
-
-getTixPath :: String -> String -> FilePath
-getTixPath hpcDir testSuiteName = tixDir hpcDir ++ testSuiteName ++ "/" ++ getTixFileName testSuiteName
+import           Control.Applicative
+import           Control.Monad
+import           Data.List                  (nub)
+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.Coveralls.Util
+import           Trace.Hpc.Tix
+
+data HpcDir = HpcDir
+  { tixDir        :: !FilePath
+  , mixDir        :: !FilePath
+  } deriving (Show, Eq)
+
+getHpcDir :: Config -> IO (Either String HpcDir)
+getHpcDir config
+    | useStackCov config = stackHpcDir
+getHpcDir config = buildHpcDir (tixDirPath config) (mixDirPath config)
+
+cabalDistDir :: FilePath
+cabalDistDir = "dist/"
+
+cabalHpcDirs :: [FilePath]
+cabalHpcDirs = map (cabalDistDir ++) ["hpc/vanilla/", "hpc/"]
+
+stackHpcDir :: IO (Either String HpcDir)
+stackHpcDir = do
+    canExecStack <- checkStackVersion
+    canGetStackHpc <- whenM canExecStack (Left "cannot exec `stack`") $ do
+        isStackProject <- checkStackProject
+        return $ if isStackProject
+            then Right ()
+            else Left "this is not a stack project"
+
+    case canGetStackHpc of
+        Right _  -> Right <$> getStackHpcDir
+        Left msg -> return $ Left msg
+
+getStackHpcDir :: IO HpcDir
+getStackHpcDir = HpcDir
+    <$> ((</>) <$> stackHpcRootPath <*> stackProjectName)
+    <*> stackDistHpcRootPath
+
+buildHpcDir :: Maybe FilePath -> Maybe FilePath -> IO (Either String HpcDir)
+buildHpcDir (Just tixD) (Just mixD) = return . Right $ HpcDir tixD mixD
+buildHpcDir mtixD mmixD = do
+    mPath <- firstExistingDirectory cabalHpcDirs
+    mhpcDir <- case mPath of
+        Just hpcDir -> return . Right $ HpcDir
+          { tixDir        = hpcDir </> "tix"
+          , mixDir        = hpcDir </> "mix"
+          }
+        Nothing     -> do
+            mhpcDir <- stackHpcDir
+            case mhpcDir of
+                Right _ -> return mhpcDir
+                Left  _ -> return . Left $ "not found either cabal or stack hpc directory"
+
+    case mhpcDir of
+        Left _       -> return mhpcDir
+        Right hpcDir -> return . Right $ HpcDir
+          { tixDir        = fromMaybe (tixDir hpcDir) mtixD
+          , mixDir        = fromMaybe (mixDir hpcDir) mmixD
+          }
+
+getMixDirPaths :: Maybe String -- ^ target package name-version
+               -> HpcDir       -- ^ hpc output base directory
+               -> String       -- ^ test suite name
+               -> TixModule    -- ^ tix module
+               -> [FilePath]   -- ^ mix file paths
+getMixDirPaths mPkgNameVer hpcDir testSuiteName tix = nub $ do
+    dirName <- dirs
+    return $ mixDir hpcDir </> dirName
+    where
+        dirs = case span (/= '/') modName of
+              (_, [])        -> [ testSuiteName ]
+              (packageId, _) -> [ "", packageId ] ++ maybe [] pure mPkgNameVer
+
+        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,47 @@
+module Trace.Hpc.Coveralls.Stack
+    ( checkStackVersion
+    , checkStackProject
+    , stackProjectName
+    , stackPath
+    , stackHpcRootPath
+    , stackDistHpcRootPath
+    ) where
+
+import           Control.Applicative
+import           Control.Exception
+import           Data.List                (isPrefixOf)
+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
+
+checkStackProject :: IO Bool
+checkStackProject = do
+     projectRoot <- stackPath "project-root"
+     stackRoot   <- stackPath "stack-root"
+     return . not $ isPrefixOf stackRoot projectRoot
+
+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,10 @@ 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
+
+whenM :: Monad m => Bool -> a -> m a -> m a
+whenM True  _ m = m
+whenM False v _ = return v

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]