diff --git a/README.md b/README.md index 5f2e34c..acc3679 100644 --- a/README.md +++ b/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. diff --git a/hpc-coveralls.cabal b/hpc-coveralls.cabal index f2acb39..68bb7a5 100644 --- a/hpc-coveralls.cabal +++ b/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 diff --git a/src/HpcCoverallsCmdLine.hs b/src/HpcCoverallsCmdLine.hs index 0aa4f9f..b8160e6 100644 --- a/src/HpcCoverallsCmdLine.hs +++ b/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" diff --git a/src/HpcCoverallsMain.hs b/src/HpcCoverallsMain.hs index 8d51112..4eee243 100644 --- a/src/HpcCoverallsMain.hs +++ b/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" diff --git a/src/Trace/Hpc/Coverage.hs b/src/Trace/Hpc/Coverage.hs new file mode 100644 index 0000000..c2c47e7 --- /dev/null +++ b/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 +-- 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 diff --git a/src/Trace/Hpc/Coveralls.hs b/src/Trace/Hpc/Coveralls.hs index c14ab24..6ea75ea 100644 --- a/src/Trace/Hpc/Coveralls.hs +++ b/src/Trace/Hpc/Coveralls.hs @@ -9,7 +9,10 @@ -- -- Functions for converting and sending hpc output to coveralls.io. -module Trace.Hpc.Coveralls ( generateCoverallsFromTix ) where +module Trace.Hpc.Coveralls ( toCoverallsJson + , strictConverter + , looseConverter + ) where import Control.Applicative import Data.Aeson @@ -18,25 +21,16 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Digest.Pure.MD5 import Data.Function import Data.List +import Data.Traversable (for) +import Data.Semigroup (Semigroup((<>))) import qualified Data.Map.Strict as M -import System.Exit (exitFailure) -import Trace.Hpc.Coveralls.Config import Trace.Hpc.Coveralls.GitInfo (GitInfo) import Trace.Hpc.Coveralls.Lix -import Trace.Hpc.Coveralls.Paths import Trace.Hpc.Coveralls.Types import Trace.Hpc.Coveralls.Util import Trace.Hpc.Mix -import Trace.Hpc.Tix import Trace.Hpc.Util -type ModuleCoverageData = ( - String, -- file source code - Mix, -- module index data - [Integer]) -- tixs recorded by hpc - -type TestSuiteCoverageData = M.Map FilePath ModuleCoverageData - -- single file coverage data in the format defined by coveralls.io type SimpleCoverage = [CoverageValue] @@ -87,7 +81,7 @@ coverageToJson converter filePath (source, mix, tixs) = object [ getExprSource' = getExprSource $ lines source toCoverallsJson :: String -> String -> Maybe String -> GitInfo -> LixConverter -> TestSuiteCoverageData -> Value -toCoverallsJson serviceName jobId repoTokenM gitInfo converter testSuiteCoverageData = +toCoverallsJson serviceName jobId repoTokenM gitInfo converter (TestSuiteCoverageData testSuiteCoverageData) = object $ if serviceName == "travis-ci" then withRepoToken else withGitInfo where base = [ "service_job_id" .= jobId, @@ -96,61 +90,3 @@ toCoverallsJson serviceName jobId repoTokenM gitInfo converter testSuiteCoverage toJsonCoverageList = map (uncurry $ coverageToJson converter) . M.toList withRepoToken = mcons (("repo_token" .=) <$> repoTokenM) base withGitInfo = ("git" .= gitInfo) : withRepoToken - -mergeModuleCoverageData :: ModuleCoverageData -> ModuleCoverageData -> ModuleCoverageData -mergeModuleCoverageData (source, mix, tixs1) (_, _, tixs2) = - (source, mix, zipWith (+) 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] - --- | Create a list of coverage data from the tix input -readCoverageData :: Maybe String -- ^ Package name-version - -> String -- ^ 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 - mTix <- readTix tixPath - case mTix of - Nothing -> putStrLn ("Couldn't find the file " ++ tixPath) >> dumpDirectoryTree hpcDir >> ioFailure - Just (Tix tixs) -> do - mixs <- mapM (readMix' mPkgNameVer hpcDir testSuiteName) tixs - let files = map filePath mixs - sources <- mapM readFile files - let coverageDataList = zip4 files sources mixs (map tixModuleTixs tixs) - let filteredCoverageDataList = filter sourceDirFilter coverageDataList - return $ M.fromList $ map toFirstAndRest filteredCoverageDataList - where filePath (Mix fp _ _ _ _) = fp - sourceDirFilter = not . matchAny excludeDirPatterns . fst4 - --- | Generate coveralls json formatted code coverage from hpc coverage data -generateCoverallsFromTix :: String -- ^ CI name - -> String -- ^ CI Job ID - -> GitInfo -- ^ Git repo information - -> Config -- ^ hpc-coveralls configuration - -> Maybe String -- ^ Package name-version - -> IO Value -- ^ code coverage result in json format -generateCoverallsFromTix serviceName jobId gitInfo config mPkgNameVer = do - mHpcDir <- firstExistingDirectory hpcDirs - case mHpcDir of - Nothing -> putStrLn "Couldn't find the hpc data directory" >> dumpDirectory distDir >> ioFailure - Just 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 - -ioFailure :: IO a -ioFailure = putStrLn ("You can get support at " ++ gitterUrl) >> exitFailure - where gitterUrl = "https://gitter.im/guillaume-nargeot/hpc-coveralls" :: String diff --git a/src/Trace/Hpc/Coveralls/Cabal.hs b/src/Trace/Hpc/Coveralls/Cabal.hs index b303045..2338cac 100644 --- a/src/Trace/Hpc/Coveralls/Cabal.hs +++ b/src/Trace/Hpc/Coveralls/Cabal.hs @@ -9,25 +9,32 @@ -- -- Functions for reading cabal package name and version. -module Trace.Hpc.Coveralls.Cabal (currDirPkgNameVer, getPackageNameVersion) where +module Trace.Hpc.Coveralls.Cabal (getPackageId, getPackageNameVersion, getPackageFromDir, getPackages, readTestSuiteNames) where import Control.Applicative import Control.Monad -import Control.Monad.Trans.Maybe import Data.List (intercalate, isSuffixOf) -import Distribution.Package +import Data.Semigroup ((<>)) +import Distribution.Package (unPackageName, pkgName, pkgVersion) import Distribution.PackageDescription import Distribution.PackageDescription.Parse +import Distribution.Types.UnqualComponentName (unUnqualComponentName) import Distribution.Version import System.Directory +import Trace.Hpc.Coveralls.Types getCabalFile :: FilePath -> IO (Maybe FilePath) getCabalFile dir = do - files <- (filter isCabal <$> getDirectoryContents dir) >>= filterM doesFileExist - case files of - [file] -> return $ Just file - _ -> return Nothing - where isCabal filename = ".cabal" `isSuffixOf` filename && length filename > 6 + cabalFilesInDir <- filter isCabal <$> getDirectoryContents dir + cabalFiles <- filterM doesFileExist (mkFullPath <$> cabalFilesInDir) + case cabalFiles of + [file] -> do + return $ Just file + _ -> do + return Nothing + where + isCabal filename = ".cabal" `isSuffixOf` filename && length filename > 6 + mkFullPath = ((dir <> "/") <>) getPackageNameVersion :: FilePath -> IO (Maybe String) getPackageNameVersion file = do @@ -40,10 +47,56 @@ getPackageNameVersion file = do version = showVersion (pkgVersion pkg) showVersion = intercalate "." . map show . versionNumbers -currDirPkgNameVer :: IO (Maybe String) -currDirPkgNameVer = runMaybeT $ pkgNameVersion currentDir - where pkgNameVersion = MaybeT . getPackageNameVersion <=< MaybeT . getCabalFile - currentDir = "." +getPackageId :: FilePath -> IO (Maybe PackageIdentifier) +getPackageId cabalFile = do + orig <- readFile cabalFile + case parsePackageDescription orig of + ParseFailed _ -> return Nothing + ParseOk _warnings gpd -> return . Just $ PackageIdentifier name version + where pkg = package . packageDescription $ gpd + name = unPackageName $ pkgName pkg + version = showVersion (pkgVersion pkg) + showVersion = intercalate "." . map show . versionNumbers + +getPackageFromDir :: FilePath -> IO (Maybe Package) +getPackageFromDir dir = do + exists <- doesDirectoryExist dir + if exists == False + then pure Nothing + else do + mCabalFilePath <- getCabalFile dir + case mCabalFilePath of + Nothing -> pure Nothing + Just cabalFilePath -> do + mPkgId <- getPackageId cabalFilePath + pure $ Package dir cabalFilePath <$> mPkgId + +-- | Get a list of packages. +-- +-- This function works by finding cabal files and parsing them to +-- provide package descriptions. You can provide either a full cabal +-- file paths (for legacy reasons) or directories containing cabal +-- files. Both will be used to generate a list of packages. If you +-- provide none, the current directory will be searched. +getPackages + :: FindPackageRequest + -> IO [Package] +getPackages = foldr foldF (pure []) + where + foldF :: (FilePath, Maybe FilePath) -> IO [Package] -> IO [Package] + foldF x acc = do + mPkg <- iter x + case mPkg of + Nothing -> acc + Just pkg -> (pkg:) <$> acc + + iter :: (FilePath, Maybe FilePath) -> IO (Maybe Package) + iter (rootDir, Just cabalFilePath) = do + mPkgId <- getPackageId cabalFilePath + pure $ Package rootDir cabalFilePath <$> mPkgId + iter (rootDir, Nothing) = do + mPkg <- getPackageFromDir rootDir + pure mPkg #if !(MIN_VERSION_Cabal(1,22,0)) unPackageName :: PackageName -> String @@ -54,3 +107,13 @@ unPackageName (PackageName name) = name versionNumbers :: Version -> [Int] versionNumbers = versionBranch #endif + +readTestSuiteNames :: FilePath -> IO [String] +readTestSuiteNames cabalFile = do + contents <- readFile cabalFile + case parsePackageDescription contents of + ParseFailed _ -> return [] + ParseOk _warnings gpd -> return $ getTestSuiteNames gpd + +getTestSuiteNames :: GenericPackageDescription -> [String] +getTestSuiteNames = foldMap ((:[]) . unUnqualComponentName . fst) . condTestSuites diff --git a/src/Trace/Hpc/Coveralls/Config.hs b/src/Trace/Hpc/Coveralls/Config.hs index 0daa895..8223e0a 100644 --- a/src/Trace/Hpc/Coveralls/Config.hs +++ b/src/Trace/Hpc/Coveralls/Config.hs @@ -3,10 +3,12 @@ module Trace.Hpc.Coveralls.Config where import Trace.Hpc.Coveralls.Types (CoverageMode) data Config = Config { - excludedDirs :: ![FilePath], - coverageMode :: !CoverageMode, - cabalFile :: !(Maybe FilePath), - serviceName :: !(Maybe String), - repoToken :: !(Maybe String), - testSuites :: ![String] + excludedDirs :: ![FilePath], + coverageMode :: !CoverageMode, + cabalFile :: !(Maybe FilePath), + serviceName :: !(Maybe String), + repoToken :: !(Maybe String), + hpcDirOverrides :: ![FilePath], + packageDirs :: ![FilePath], + testSuites :: ![String] } diff --git a/src/Trace/Hpc/Coveralls/Paths.hs b/src/Trace/Hpc/Coveralls/Paths.hs index 9c153f9..977c8cd 100644 --- a/src/Trace/Hpc/Coveralls/Paths.hs +++ b/src/Trace/Hpc/Coveralls/Paths.hs @@ -13,20 +13,27 @@ module Trace.Hpc.Coveralls.Paths where import Control.Monad import Data.Maybe +import Data.Semigroup ((<>)) import Data.Traversable (traverse) import System.Directory ( - doesDirectoryExist, getDirectoryContents + doesDirectoryExist, getDirectoryContents, doesFileExist ) import System.Directory.Tree ( AnchoredDirTree(..), dirTree, readDirectoryWith ) import Trace.Hpc.Tix +import Trace.Hpc.Coveralls.Types distDir :: FilePath distDir = "dist/" -hpcDirs :: [FilePath] -hpcDirs = map (distDir ++) ["hpc/vanilla/", "hpc/"] +hpcDistDirs :: [FilePath] +hpcDistDirs = map (distDir ++) ["hpc/vanilla/", "hpc/"] + +cabalProjectHpcDirs :: FilePath -> [PackageIdentifier] -> [FilePath] +cabalProjectHpcDirs hpcBaseDir = fmap pkgDir + where + pkgDir p = hpcBaseDir <> "/" <> (asNameVer p) <> "/" tixDir :: String -> FilePath tixDir = (++ "tix/") @@ -45,8 +52,18 @@ getMixPath mPkgNameVer hpcDir testSuiteName tix = mixDir hpcDir ++ dirName ++ "/ (packageId, _) -> fromMaybe packageId mPkgNameVer TixModule modName _ _ _ = tix -getTixPath :: String -> String -> FilePath -getTixPath hpcDir testSuiteName = tixDir hpcDir ++ testSuiteName ++ "/" ++ getTixFileName testSuiteName +-- | Given a list of hpc data directories, return a list of possible +-- tix file paths for the given test suite. +possibleTixFileLocations :: [FilePath] -> String -> [FilePath] +possibleTixFileLocations hpcDirs testSuiteName = possibleTixFiles + where + -- List of possible tix file paths + possibleTixFiles :: [FilePath] + possibleTixFiles = tixFileInDir <$> hpcDirs + + -- Path of the tix file in the given hpc directory. + tixFileInDir :: FilePath -> FilePath + tixFileInDir hpcDir = tixDir hpcDir ++ testSuiteName ++ "/" ++ getTixFileName testSuiteName firstExistingDirectory :: [FilePath] -> IO (Maybe FilePath) firstExistingDirectory = fmap msum . mapM pathIfExist @@ -54,6 +71,12 @@ firstExistingDirectory = fmap msum . mapM pathIfExist pathExists <- doesDirectoryExist path return $ if pathExists then Just path else Nothing +firstExistingFile :: [FilePath] -> IO (Maybe FilePath) +firstExistingFile = fmap msum . mapM fileIfExist + where fileIfExist path = do + fileExists <- doesFileExist path + return $ if fileExists then Just path else Nothing + dumpDirectory :: FilePath -> IO () dumpDirectory path = do directoryExists <- doesDirectoryExist path diff --git a/src/Trace/Hpc/Coveralls/Types.hs b/src/Trace/Hpc/Coveralls/Types.hs index 4ac032f..7c2df27 100644 --- a/src/Trace/Hpc/Coveralls/Types.hs +++ b/src/Trace/Hpc/Coveralls/Types.hs @@ -12,9 +12,11 @@ module Trace.Hpc.Coveralls.Types where import Data.Data +import Data.Semigroup import Network.Curl import System.Console.CmdArgs.Default import Trace.Hpc.Mix +import qualified Data.Map.Strict as M type CoverageEntry = ( [MixEntry], -- mix entries @@ -40,3 +42,56 @@ data CoverageMode = StrictlyFullLines data PostResult = PostSuccess URLString -- ^ Coveralls job url | PostFailure String -- ^ error message + +-- | Name and version used to identify a package. +data PackageIdentifier + = PackageIdentifier { pkgIdName :: String + , pkgIdVersion :: String + } + deriving (Eq, Show) + +-- | Get package identifier formatted as: "$name-$ver". +asNameVer :: PackageIdentifier -> String +asNameVer (PackageIdentifier name ver) = name <> "-" <> ver + +-- | Description of a package from the perspective of hpc-coveralls. +data Package + = Package { pkgRootDir :: FilePath + , pkgCabalFilePath :: FilePath + , pkgId :: PackageIdentifier + } + deriving (Eq, Show) + +type FindPackageRequest + = [ + ( FilePath + -- ^ Project root directory + , Maybe FilePath + -- ^ Optional explicit path to cabal file + ) + ] + +searchTheseDirectories :: [FilePath] -> FindPackageRequest +searchTheseDirectories = fmap (\f -> (f, Nothing)) + +useExplicitCabalFiles :: [(FilePath, Maybe FilePath)] -> FindPackageRequest +useExplicitCabalFiles = id + +type ModuleCoverageData = ( + String, -- file source code + Mix, -- module index data + [Integer]) -- tixs recorded by hpc + +data TestSuiteCoverageData = TestSuiteCoverageData (M.Map FilePath ModuleCoverageData) + +mergeModuleCoverageData :: ModuleCoverageData -> ModuleCoverageData -> ModuleCoverageData +mergeModuleCoverageData (source, mix, tixs1) (_, _, tixs2) = + (source, mix, zipWith (+) tixs1 tixs2) + +instance Semigroup TestSuiteCoverageData where + (<>) (TestSuiteCoverageData data1) (TestSuiteCoverageData data2) = TestSuiteCoverageData (M.unionWith mergeModuleCoverageData data1 data2) + +instance Monoid TestSuiteCoverageData where + mempty = TestSuiteCoverageData mempty + + mappend = (<>) diff --git a/src/Trace/Hpc/Coveralls/Util.hs b/src/Trace/Hpc/Coveralls/Util.hs index 7a3f5ea..3a63747 100644 --- a/src/Trace/Hpc/Coveralls/Util.hs +++ b/src/Trace/Hpc/Coveralls/Util.hs @@ -10,6 +10,13 @@ module Trace.Hpc.Coveralls.Util where import Data.List +import Data.Semigroup ((<>)) +import System.Directory (doesDirectoryExist) +import System.Exit (exitFailure) +import Trace.Hpc.Coveralls.Config +import Trace.Hpc.Coveralls.Cabal +import Trace.Hpc.Coveralls.Types +import Trace.Hpc.Coveralls.Paths fst3 :: (a, b, c) -> a fst3 (x, _, _) = x @@ -58,3 +65,77 @@ 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 + +foldFor + :: (Monoid m, Foldable t) + => t a + -> (a -> m) + -> m +foldFor = (flip foldMap) + +findHpcDataDirs :: Config -> IO [FilePath] +findHpcDataDirs config = do + case hpcDirOverrides config of + [] -> do + mHpcDir <- firstExistingDirectory hpcDistDirs + case mHpcDir of + Nothing -> putStrLn "Couldn't find the hpc data directory" >> dumpDirectory distDir >> ioFailure + Just hpcDir -> pure [hpcDir] + potentialHpcDirs -> do + foldFor potentialHpcDirs $ \potentialHpcDir -> do + let hpcDir = potentialHpcDir <> "/" + doesExist <- doesDirectoryExist hpcDir + if doesExist == False + then putStrLn ("The hpc data directory override provided does not exist: " <> hpcDir) >> ioFailure + else pure [hpcDir] + +findPackages :: Config -> IO [Package] +findPackages config = + let + currDir = "./" + + findPkgRequest :: FindPackageRequest + findPkgRequest = + case cabalFile config of + Just cabalFilePath -> + useExplicitCabalFiles [(currDir, Just cabalFilePath)] + Nothing -> + let + packageDirOverrides :: [FilePath] + packageDirOverrides = packageDirs config + packageDirs' :: [FilePath] + packageDirs' = + if length packageDirOverrides == 0 + then [currDir] + else packageDirOverrides + in + searchTheseDirectories packageDirs' + + renderFindPackageRequestError :: FindPackageRequest -> String + renderFindPackageRequestError request = + let + render :: (FilePath, Maybe FilePath) -> String + render (_, Just cabalFilePath) = "\nAt location '" <> cabalFilePath <> "'" + render (dir, Nothing) = "\nIn directory '" <> dir <> "'" + + indent :: String -> String + indent = (" " <>) + in "Couldn't find cabal file..." <> foldMap (indent . render) request + + in do + pkgs <- getPackages findPkgRequest + case pkgs of + [] -> putStrLn (renderFindPackageRequestError findPkgRequest) >> ioFailure + ps -> pure ps + +findTestSuiteNames :: Config -> [Package] -> IO [String] +findTestSuiteNames config pkgs = do + case testSuites config of + [] -> do + let cabalFiles = pkgCabalFilePath <$> pkgs + foldMap readTestSuiteNames cabalFiles + testSuiteNames -> pure testSuiteNames + +ioFailure :: IO a +ioFailure = putStrLn ("You can get support at " ++ gitterUrl) >> exitFailure + where gitterUrl = "https://gitter.im/guillaume-nargeot/hpc-coveralls" :: String