From 183bd05df3b94031226c63d946619f0f05ea2c51 Mon Sep 17 00:00:00 2001 From: Mizunashi Mana Date: Thu, 8 Jun 2017 03:24:14 +0900 Subject: [PATCH] Add stack support --- hpc-coveralls.cabal | 9 ++- src/HpcCoverallsCmdLine.hs | 4 ++ src/HpcCoverallsMain.hs | 3 +- src/Trace/Hpc/Coveralls.hs | 42 ++++++----- src/Trace/Hpc/Coveralls/Config.hs | 2 + src/Trace/Hpc/Coveralls/Paths.hs | 111 +++++++++++++++++++++--------- src/Trace/Hpc/Coveralls/Stack.hs | 38 ++++++++++ src/Trace/Hpc/Coveralls/Util.hs | 4 ++ test/TestHpcCoverallsUtil.hs | 7 +- 9 files changed, 164 insertions(+), 56 deletions(-) create mode 100644 src/Trace/Hpc/Coveralls/Stack.hs diff --git a/hpc-coveralls.cabal b/hpc-coveralls.cabal index f2acb39..ca50837 100644 --- a/hpc-coveralls.cabal +++ b/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 diff --git a/src/HpcCoverallsCmdLine.hs b/src/HpcCoverallsCmdLine.hs index 0aa4f9f..ee85590 100644 --- a/src/HpcCoverallsCmdLine.hs +++ b/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 diff --git a/src/HpcCoverallsMain.hs b/src/HpcCoverallsMain.hs index 8d51112..18012cf 100644 --- a/src/HpcCoverallsMain.hs +++ b/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) diff --git a/src/Trace/Hpc/Coveralls.hs b/src/Trace/Hpc/Coveralls.hs index c14ab24..0e95967 100644 --- a/src/Trace/Hpc/Coveralls.hs +++ b/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 diff --git a/src/Trace/Hpc/Coveralls/Config.hs b/src/Trace/Hpc/Coveralls/Config.hs index 0daa895..88e1d9b 100644 --- a/src/Trace/Hpc/Coveralls/Config.hs +++ b/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] diff --git a/src/Trace/Hpc/Coveralls/Paths.hs b/src/Trace/Hpc/Coveralls/Paths.hs index 9c153f9..909f42b 100644 --- a/src/Trace/Hpc/Coveralls/Paths.hs +++ b/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 diff --git a/src/Trace/Hpc/Coveralls/Stack.hs b/src/Trace/Hpc/Coveralls/Stack.hs new file mode 100644 index 0000000..8a50d1c --- /dev/null +++ b/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 diff --git a/src/Trace/Hpc/Coveralls/Util.hs b/src/Trace/Hpc/Coveralls/Util.hs index 7a3f5ea..f7b0646 100644 --- a/src/Trace/Hpc/Coveralls/Util.hs +++ b/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 diff --git a/test/TestHpcCoverallsUtil.hs b/test/TestHpcCoverallsUtil.hs index 3c28ad9..38d0a4f 100644 --- a/test/TestHpcCoverallsUtil.hs +++ b/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]