diff --git a/USAGE.txt b/USAGE.txt --- a/USAGE.txt +++ b/USAGE.txt @@ -1,10 +1,10 @@ Usage: - stack-hpc-coveralls [options] + shc [options] ... Options: - -h --help show this help - --hpc-dir= base HPC directory - --mix-dir= directory in which HPC stores mix files - --repo-token Coveralls repo token - --partial-coverage allow partial line coverage - --dont-send display Coveralls JSON instead of sending it + -h --help show this help + --hpc-dir= base HPC directory + --mix-dir= directory in which HPC stores mix files + --repo-token= Coveralls repo token + --partial-coverage allow partial line coverage + --dont-send display Coveralls JSON instead of sending it diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,18 +1,25 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} module Main where -import Data.List (find) -import Data.Maybe (isJust) -import Data.Aeson (encode) -import qualified Data.ByteString.Lazy as BSL -import Control.Applicative (pure, (<$>), (<*>)) -import Control.Concurrent (threadDelay) -import System.Console.Docopt -import System.Environment (getArgs, getEnv, getEnvironment) -import System.Exit (exitFailure) +import Control.Monad (unless) +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy as BSL +import Data.List (find) +import Data.Maybe (isJust) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative (pure, (<$>), (<*>)) +#endif +import Control.Concurrent (threadDelay) +import System.Console.Docopt +import System.Environment (getArgs, getEnv, getEnvironment) +import System.Exit (exitFailure) -import SHC +import SHC.Api +import SHC.Coverage +import SHC.Types +import SHC.Utils urlApiV1 :: String @@ -44,10 +51,12 @@ getConfig :: Arguments -> IO Config getConfig args = do - -- TODO: Read from Cabal? pn <- args `getArgOrExit` argument "package-name" + let suites = args `getAllArgs` argument "suite-name" + unless (not $ null suites) $ + putStrLn "Error: provide at least one test-suite name" >> exitFailure (sn, jId) <- getServiceAndJobId - Config <$> args `getArgOrExit` argument "suite-name" + Config <$> pure suites <*> pure sn <*> pure jId <*> pure (args `getArg` longOption "repo-token") @@ -61,6 +70,10 @@ main :: IO () main = do args <- parseArgsOrExit patterns =<< getArgs + stackGood <- checkStackVersion + unless stackGood $ do + putStrLn "Error: at least Stack 0.1.7 is required" + exitFailure conf <- getConfig args coverallsJson <- generateCoverallsFromTix conf if args `isPresent` longOption "dont-send" @@ -68,14 +81,15 @@ else do response <- sendData conf urlApiV1 coverallsJson case response of - PostSuccess url -> do - putStrLn $ "URL: " ++ url + PostSuccess u -> do + let apiUrl = u ++ ".json" + putStrLn $ "Job URL: " ++ apiUrl -- wait 5 seconds until the page is available threadDelay $ 5 * 1000 * 1000 - coverageResult <- readCoverageResult url + coverageResult <- readCoverageResult apiUrl case coverageResult of - Just totalCov -> putStrLn $ "Coverage: " ++ totalCov - Nothing -> putStrLn "Failed to read total coverage" + Just totalCov -> putStrLn $ "Coverage: " ++ show totalCov + Nothing -> putStrLn "Failed to read total coverage" PostFailure msg -> do putStrLn $ "Error: " ++ msg exitFailure diff --git a/src/SHC.hs b/src/SHC.hs deleted file mode 100644 --- a/src/SHC.hs +++ /dev/null @@ -1,17 +0,0 @@ -module SHC - ( Config(..) - , ConversionType(..) - , PostResult(..) - , generateCoverallsFromTix - , sendData - , readCoverageResult - , getHpcDir - , getMixDir - , getGitInfo - ) where - - -import SHC.Types -import SHC.Api -import SHC.Utils -import SHC.Coveralls diff --git a/src/SHC/Api.hs b/src/SHC/Api.hs --- a/src/SHC/Api.hs +++ b/src/SHC/Api.hs @@ -1,24 +1,42 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: SHC.Lix +-- Copyright: (c) 2015 Michele Lacchia +-- License: ISC +-- Maintainer: Michele Lacchia +-- Stability: experimental +-- Portability: portable +-- +-- Functions for sending data to Coveralls.io and reading results. + module SHC.Api (sendData, readCoverageResult) where -import Safe (atMay, headMay) -import Data.Aeson (Value, encode) -import Data.Aeson.Lens (key, _String) -import qualified Data.Text as T -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import Codec.Binary.UTF8.String (decode) -import Control.Applicative ((<$>)) -import Control.Lens -import Network.Wreq -import Network.HTTP.Client (RequestBody(RequestBodyLBS)) -import Network.HTTP.Client.MultipartFormData (partFileRequestBody) +import Codec.Binary.UTF8.String (decode) +import Data.Aeson (Value, encode) +import Data.Aeson.Lens (key, _Double, _String) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import Control.Lens +import Network.HTTP.Client (RequestBody (RequestBodyLBS)) +import Network.HTTP.Client.MultipartFormData (partFileRequestBody) +import Network.Wreq -import SHC.Types +import SHC.Types (Config (..), + PostResult (..)) -sendData :: Config -> String -> Value -> IO PostResult +-- | Send coverage JSON to Coveralls.io. +sendData :: Config -- ^ SHC configuration + -> String -- ^ URL + -> Value -- ^ The JSON object + -> IO PostResult sendData conf url json = do r <- post url [partFileRequestBody "json_file" fileName requestBody] if r ^. responseStatus . statusCode == 200 @@ -36,18 +54,8 @@ Just url -> PostSuccess $ T.unpack url Nothing -> PostFailure "Error: malformed response body" --- | Extract the total coverage percentage value from coveralls coverage result --- page content. The current implementation is kept as low level as possible --- in order not to increase the library build time, by not relying on --- additional packages. -extractCoverage :: T.Text -> Maybe T.Text -extractCoverage body = T.splitOn "<" - <$> T.splitOn prefix body `atMay` 1 >>= headMay - where prefix = "div class='run-statistics'>\n" - --- | Read the coveraege result page from coveralls.io -readCoverageResult :: String -> IO (Maybe String) +-- | Read the coverage results from Coveralls.io. +readCoverageResult :: String -> IO (Maybe Double) readCoverageResult url = do r <- get url - return . fmap T.unpack . extractCoverage $ - r ^. responseBody . _String + return $ r ^? responseBody . key "covered_percent" . _Double diff --git a/src/SHC/Coverage.hs b/src/SHC/Coverage.hs new file mode 100644 --- /dev/null +++ b/src/SHC/Coverage.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: SHC.Coverage +-- Copyright: (c) 2015 Michele Lacchia +-- License: ISC +-- Maintainer: Michele Lacchia +-- Stability: experimental +-- +-- Functions for reading, converting and sending HPC output to coveralls.io. + +module SHC.Coverage + where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Data.Aeson +import Data.Aeson.Types () +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Digest.Pure.MD5 +import Data.Function +import Data.List +import qualified Data.Map.Strict as M +import SHC.Lix +import SHC.Types +import SHC.Utils +import System.Exit (exitFailure) +import System.FilePath (()) +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 + +-- Is there a way to restrict this to only Number and Null? +type CoverageValue = Value + +-- Single file coverage data in the format defined by coveralls.io +type SimpleCoverage = [CoverageValue] +type LixConverter = Lix -> SimpleCoverage + +strictConverter :: LixConverter +strictConverter = map $ \case + Full -> Number 1 + Partial -> Number 0 + None -> Number 0 + Irrelevant -> Null + +looseConverter :: LixConverter +looseConverter = map $ \case + Full -> Number 2 + Partial -> Number 1 + None -> Number 0 + Irrelevant -> Null + +readMix' :: Config -> TixModule -> IO Mix +readMix' conf tix = readMix [SHC.Types.mixDir conf] (Right tix) + +-- | Generate Coveralls JSON formatted code coverage from HPC coverage data +generateCoverallsFromTix :: Config -> IO Value +generateCoverallsFromTix conf = do + testSuitesCoverages <- mapM (readCoverageData conf) testSuitesName + let coverageData = mergeCoverageData testSuitesCoverages + return $ toCoverallsJson conf converter coverageData + where testSuitesName = suitesName conf + converter = case conversion conf of + FullLines -> strictConverter + PartialLines -> looseConverter + +-- | Create a list of coverage data from the tix input +readCoverageData :: Config -> String -> IO TestSuiteCoverageData +readCoverageData conf suite = do + let tixPath = hpcDir conf suite getTixFileName suite + mTix <- readTix tixPath + case mTix of + Nothing -> putStrLn ("Couldn't find the file " ++ tixPath) >> + exitFailure + Just (Tix tixs) -> do + mixs <- mapM (readMix' conf) tixs + let files = map filePath mixs + sources <- mapM readFile files + let coverageData = zip4 files sources mixs (map tixModuleTixs tixs) + let filteredCoverageData = filter sourceDirFilter coverageData + return $ M.fromList $ map toFirstAndRest filteredCoverageData + where filePath (Mix fp _ _ _ _) = fp + sourceDirFilter = not . matchAny excludeDirPatterns . fst4 + excludeDirPatterns = [] -- XXX: for now + +toCoverallsJson :: Config -> LixConverter -> TestSuiteCoverageData -> Value +toCoverallsJson conf converter testSuiteCoverageData = + object $ if serviceName conf == "travis-ci" + then withRepoToken + else withGitInfo + where base = [ "service_job_id" .= jobId conf + , "service_name" .= serviceName conf + , "source_files" .= toJsonList testSuiteCoverageData + ] + toJsonList = map (uncurry $ coverageToJson converter) . M.toList + withRepoToken = mcons (("repo_token" .=) <$> repoToken conf) base + withGitInfo = ("git" .= gitInfo conf) : withRepoToken + +coverageToJson :: LixConverter -> FilePath -> ModuleCoverageData -> Value +coverageToJson converter path (source, mix, tixs) = + object [ "name" .= path + , "source_digest" .= (show . md5 . LBS.pack) source + , "coverage" .= coverage + ] + where coverage = toSimpleCoverage converter lineCount mixEntriesTixs + lineCount = length $ lines source + mixEntriesTixs = groupMixEntryTixs mixEntryTixs + mixEntryTixs = zip3 mixEntries tixs (map getExprSource' mixEntries) + Mix _ _ _ _ mixEntries = mix + getExprSource' = getExprSource $ lines source + +mergeCoverageData :: [TestSuiteCoverageData] -> TestSuiteCoverageData +mergeCoverageData = foldr1 $ M.unionWith mergeModule + where mergeModule (source, mix, tixs1) (_, _, tixs2) = + (source, mix, zipWith (+) tixs1 tixs2) + +toSimpleCoverage :: LixConverter -> Int -> [CoverageEntry] -> SimpleCoverage +toSimpleCoverage convert lineCount = convert . toLix lineCount + +getExprSource :: [String] -> MixEntry -> [String] +getExprSource source (hpcPos, _) = subSubSeq startCol endCol subLines + where subLines = subSeq startLine endLine source + startLine = startLine' - 1 + startCol = startCol' - 1 + (startLine', startCol', endLine, endCol) = fromHpcPos hpcPos + +groupMixEntryTixs :: [(MixEntry, Integer, [String])] -> [CoverageEntry] +groupMixEntryTixs = map mergeOnLst3 . groupBy ((==) `on` fst . fst3) + where mergeOnLst3 xxs@(x:_) = (map fst3 xxs, map snd3 xxs, trd3 x) + mergeOnLst3 [] = error "mergeOnLst3 applied to empty list" diff --git a/src/SHC/Coveralls.hs b/src/SHC/Coveralls.hs deleted file mode 100644 --- a/src/SHC/Coveralls.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module: SHC.Coveralls --- Copyright: (c) 2015 Michele Lacchia --- License: ISC --- Maintainer: Michele Lacchia --- Stability: experimental --- --- Functions for reading, converting and sending HPC output to coveralls.io. - -module SHC.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 -import Data.List -import qualified Data.Map.Strict as M -import System.FilePath (()) -import System.Exit (exitFailure) -import SHC.Types -import SHC.Utils -import SHC.Lix -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 - --- Is there a way to restrict this to only Number and Null? -type CoverageValue = Value - --- Single file coverage data in the format defined by coveralls.io -type SimpleCoverage = [CoverageValue] -type LixConverter = Lix -> SimpleCoverage - -strictConverter :: LixConverter -strictConverter = map $ \case - Full -> Number 1 - Partial -> Number 0 - None -> Number 0 - Irrelevant -> Null - -looseConverter :: LixConverter -looseConverter = map $ \case - Full -> Number 2 - Partial -> Number 1 - None -> Number 0 - Irrelevant -> Null - -toSimpleCoverage :: LixConverter -> Int -> [CoverageEntry] -> SimpleCoverage -toSimpleCoverage convert lineCount = convert . toLix lineCount - -getExprSource :: [String] -> MixEntry -> [String] -getExprSource source (hpcPos, _) = subSubSeq startCol endCol subLines - where subLines = subSeq startLine endLine source - startLine = startLine' - 1 - startCol = startCol' - 1 - (startLine', startCol', endLine, endCol) = fromHpcPos hpcPos - -groupMixEntryTixs :: [(MixEntry, Integer, [String])] -> [CoverageEntry] -groupMixEntryTixs = map mergeOnLst3 . groupBy ((==) `on` fst . fst3) - where mergeOnLst3 xxs@(x : _) = (map fst3 xxs, map snd3 xxs, trd3 x) - mergeOnLst3 [] = error "mergeOnLst3 appliedTo empty list" - -coverageToJson :: LixConverter -> FilePath -> ModuleCoverageData -> Value -coverageToJson converter filePath (source, mix, tixs) = object [ - "name" .= filePath, - "source_digest" .= (show . md5 . LBS.pack) source, - "coverage" .= coverage] - where coverage = toSimpleCoverage converter lineCount mixEntriesTixs - lineCount = length $ lines source - mixEntriesTixs = groupMixEntryTixs mixEntryTixs - mixEntryTixs = zip3 mixEntries tixs (map getExprSource' mixEntries) - Mix _ _ _ _ mixEntries = mix - getExprSource' = getExprSource $ lines source - -toCoverallsJson :: Config -> LixConverter -> TestSuiteCoverageData -> Value -toCoverallsJson conf converter testSuiteCoverageData = - object $ if serviceName conf == "travis-ci" then withRepoToken else withGitInfo - where base = [ - "service_job_id" .= jobId conf, - "service_name" .= serviceName conf, - "source_files" .= toJsonCoverageList testSuiteCoverageData] - toJsonCoverageList = map (uncurry $ coverageToJson converter) . M.toList - withRepoToken = mcons (("repo_token" .=) <$> repoToken conf) base - withGitInfo = ("git" .= gitInfo conf) : withRepoToken - -mergeCoverageData :: [TestSuiteCoverageData] -> TestSuiteCoverageData -mergeCoverageData = foldr1 (M.unionWith mergeModule) - where mergeModule (source, mix, tixs1) (_, _, tixs2) = - (source, mix, zipWith (+) tixs1 tixs2) - -readMix' :: Config -> TixModule -> IO Mix -readMix' conf tix = readMix [SHC.Types.mixDir conf] (Right tix) - --- | Create a list of coverage data from the tix input -readCoverageData :: Config -> String -> IO TestSuiteCoverageData -readCoverageData conf suite = do - let tixPath = hpcDir conf suite getTixFileName suite - mTix <- readTix tixPath - case mTix of - Nothing -> putStrLn ("Couldn't find the file " ++ tixPath) >> - dumpDirectoryTree (hpcDir conf) >> exitFailure - Just (Tix tixs) -> do - mixs <- mapM (readMix' conf) 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 - excludeDirPatterns = [] -- XXX: for now - --- | Generate Coveralls JSON formatted code coverage from HPC coverage data -generateCoverallsFromTix :: Config -> IO Value -generateCoverallsFromTix conf = do - testSuitesCoverages <- mapM (readCoverageData conf) [testSuiteName] -- XXX: fix suites - let coverageData = mergeCoverageData testSuitesCoverages - return $ toCoverallsJson conf converter coverageData - where testSuiteName = suiteName conf - converter = case conversion conf of - FullLines -> strictConverter - PartialLines -> looseConverter diff --git a/src/SHC/Lix.hs b/src/SHC/Lix.hs --- a/src/SHC/Lix.hs +++ b/src/SHC/Lix.hs @@ -11,13 +11,12 @@ module SHC.Lix where -import Data.Ord -import Data.List -import Prelude hiding (getLine) -import SHC.Types -import SHC.Utils -import Trace.Hpc.Mix -import Trace.Hpc.Util +import Data.List +import Data.Ord +import SHC.Types +import SHC.Utils +import Trace.Hpc.Mix +import Trace.Hpc.Util toHit :: [Bool] -> Hit toHit [] = Irrelevant @@ -27,32 +26,31 @@ | or xs = Partial | otherwise = None -getLine :: MixEntry -> Int -getLine = fffst . fromHpcPos . fst - where fffst (x, _, _, _) = x +startLine :: MixEntry -> Int +startLine = fst4 . fromHpcPos . fst toLineHit :: CoverageEntry -> (Int, Bool) -toLineHit (entries, counts, _source) = (getLine (head entries) - 1, all (> 0) counts) +toLineHit (entries, counts, _) = (startLine (head entries) - 1, all (> 0) counts) isOtherwiseEntry :: CoverageEntry -> Bool isOtherwiseEntry (mixEntries, _, source) = source == ["otherwise"] && boxLabels == otherwiseBoxLabels where boxLabels = map snd mixEntries - otherwiseBoxLabels = [ - ExpBox False, - BinBox GuardBinBox True, - BinBox GuardBinBox False] + otherwiseBoxLabels = [ ExpBox False + , BinBox GuardBinBox True + , BinBox GuardBinBox False + ] adjust :: CoverageEntry -> CoverageEntry adjust coverageEntry@(mixEntries, tixs, source) = if isOtherwiseEntry coverageEntry && any (> 0) tixs - then (mixEntries, [1, 1, 1], source) - else coverageEntry + then (mixEntries, [1, 1, 1], source) + else coverageEntry -- | Convert hpc coverage entries into a line based coverage format toLix :: Int -- ^ Source line count -> [CoverageEntry] -- ^ Mix entries and associated hit count -> Lix -- ^ Line coverage -toLix lineCount entries = map toHit (groupByIndex lineCount sortedLineHits) +toLix lineCount entries = map toHit $ groupByIndex lineCount sortedLineHits where sortedLineHits = sortBy (comparing fst) lineHits lineHits = map (toLineHit . adjust) entries diff --git a/src/SHC/Types.hs b/src/SHC/Types.hs --- a/src/SHC/Types.hs +++ b/src/SHC/Types.hs @@ -3,18 +3,19 @@ module SHC.Types where -import Data.Aeson -import Trace.Hpc.Mix +import Data.Aeson +import Trace.Hpc.Mix data ConversionType = FullLines | PartialLines deriving (Show, Eq) -type CoverageEntry = ( [MixEntry] -- ^ Mix entries - , [Integer] -- ^ Tix values - , [String] -- ^ Entry source code - ) +type CoverageEntry = + ( [MixEntry] -- Mix entries + , [Integer] -- Tix values + , [String] -- Entry source code + ) data Hit = Full | Partial @@ -28,36 +29,36 @@ | PostFailure String deriving (Show) -data Config = Config { - suiteName :: String - , serviceName :: String - , jobId :: String - , repoToken :: Maybe String - , gitInfo :: GitInfo - , hpcDir :: FilePath - , mixDir :: FilePath - , conversion :: ConversionType - } +data Config = Config + { suitesName :: [String] + , serviceName :: String + , jobId :: String + , repoToken :: Maybe String + , gitInfo :: GitInfo + , hpcDir :: FilePath + , mixDir :: FilePath + , conversion :: ConversionType + } -data GitInfo = GitInfo { - headRef :: Commit - , branch :: String - , remotes :: [Remote] - } +data GitInfo = GitInfo + { headRef :: Commit + , branch :: String + , remotes :: [Remote] + } -data Commit = Commit { - hash :: String - , authorName :: String - , authorEmail :: String - , committerName :: String - , committerEmail :: String - , message :: String - } +data Commit = Commit + { hash :: String + , authorName :: String + , authorEmail :: String + , committerName :: String + , committerEmail :: String + , message :: String + } -data Remote = Remote { - name :: String - , url :: String - } +data Remote = Remote + { name :: String + , url :: String + } instance ToJSON GitInfo where toJSON i = object [ "head" .= headRef i diff --git a/src/SHC/Utils.hs b/src/SHC/Utils.hs --- a/src/SHC/Utils.hs +++ b/src/SHC/Utils.hs @@ -1,21 +1,30 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module: SHC.Utils +-- Copyright: (c) 2014-2015 Guillaume Nargeot +-- License: BSD3 +-- Maintainer: Michele Lacchia +-- Stability: experimental +-- +-- Utility functions used in other modules. + module SHC.Utils where -import Data.List -import Data.Function (on) -import Data.Traversable (traverse) -import Control.Monad (guard, unless) -import Control.Applicative ((<$>), (<*>)) -import System.Process (readProcess) -import System.FilePath (()) -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.Directory.Tree (AnchoredDirTree(..), dirTree, readDirectoryWith) +import Control.Monad (guard) +import Data.Function (on) +import Data.List +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>), (<*>)) +#endif +import System.FilePath (()) +import System.Process (readProcess) -import SHC.Types +import SHC.Types readP :: String -> [String] -> IO String -readP name args = init <$> readProcess name args [] -- strip trailing \n +readP cmd args = init <$> readProcess cmd args [] -- strip trailing \n git :: [String] -> IO String git = readP "git" @@ -25,14 +34,14 @@ -- | Get information about the Git repo in the current directory. getGitInfo :: IO GitInfo -getGitInfo = GitInfo <$> headRef <*> branch <*> getRemotes +getGitInfo = GitInfo <$> headRef <*> branchName <*> getRemotes where headRef = Commit <$> git ["rev-parse", "HEAD"] <*> git ["log", "-1", "--pretty=%aN"] <*> git ["log", "-1", "--pretty=%aE"] <*> git ["log", "-1", "--pretty=%cN"] <*> git ["log", "-1", "--pretty=%cE"] <*> git ["log", "-1", "--pretty=%s"] - branch = git ["rev-parse", "--abbrev-ref", "HEAD"] + branchName = git ["rev-parse", "--abbrev-ref", "HEAD"] getRemotes :: IO [Remote] getRemotes = nubBy ((==) `on` name) <$> parseRemotes <$> git ["remote", "-v"] @@ -43,28 +52,18 @@ guard $ length fields >= 2 return $ Remote (head fields) (fields !! 1) +-- | Verify that the required Stack is present. +checkStackVersion :: IO Bool +checkStackVersion = ("Version 0.1.7" `isPrefixOf`) <$> stack ["--version"] + +-- | Return the HPC data directory, given the package name. getHpcDir :: String -> IO FilePath getHpcDir package = ( package) <$> stack ["path", "--local-hpc-root"] +-- | Return the HPC mix directory, where module data is stored. getMixDir :: IO FilePath getMixDir = ( "hpc") <$> stack ["path", "--dist-dir"] -dumpDirectory :: FilePath -> IO () -dumpDirectory path = do - directoryExists <- doesDirectoryExist path - unless directoryExists $ putStrLn ("Couldn't find the directory " ++ path) - putStrLn $ "Dumping " ++ path ++ " directory content:" - contents <- getDirectoryContents path - traverse putStrLn contents - return () - -dumpDirectoryTree :: FilePath -> IO () -dumpDirectoryTree path = do - putStrLn $ "Dumping " ++ path ++ " directory tree:" - tree <- readDirectoryWith return path - traverse putStrLn $ dirTree tree - return () - fst3 :: (a, b, c) -> a fst3 (x, _, _) = x @@ -80,25 +79,21 @@ toFirstAndRest :: (a, b, c, d) -> (a, (b, c, d)) toFirstAndRest (a, b, c, d) = (a, (b, c, d)) -listToMaybe :: [a] -> Maybe [a] -listToMaybe [] = Nothing -listToMaybe xs = Just xs - mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs -mcons (Just x) xs = x : xs +mcons (Just x) xs = x:xs matchAny :: [String] -> String -> Bool matchAny patterns fileName = any (`isPrefixOf` fileName) patterns mapFirst :: (a -> a) -> [a] -> [a] -mapFirst f (x : xs) = f x : xs -mapFirst _ [] = [] +mapFirst f (x:xs) = f x : xs +mapFirst _ [] = [] mapLast :: (a -> a) -> [a] -> [a] -mapLast f [x] = [f x] -mapLast f (x : xs) = x : mapLast f xs -mapLast _ [] = [] +mapLast f [x] = [f x] +mapLast f (x:xs) = x : mapLast f xs +mapLast _ [] = [] subSeq :: Int -> Int -> [a] -> [a] subSeq start end = drop start . take end @@ -109,6 +104,6 @@ groupByIndex :: Int -> [(Int, a)] -> [[a]] groupByIndex size = take size . flip (++) (repeat []) . groupByIndex' 0 [] where groupByIndex' _ ys [] = [ys] - groupByIndex' i ys xx@((xi, x) : xs) = if xi == i - then groupByIndex' i (x : ys) xs + groupByIndex' i ys xx@((xi, x):xs) = if xi == i + then groupByIndex' i (x:ys) xs else ys : groupByIndex' (i + 1) [] xx diff --git a/stack-hpc-coveralls.cabal b/stack-hpc-coveralls.cabal --- a/stack-hpc-coveralls.cabal +++ b/stack-hpc-coveralls.cabal @@ -1,5 +1,5 @@ name: stack-hpc-coveralls -version: 0.0.0.4 +version: 0.0.1.0 synopsis: Initial project template from stack description: Please see README.md homepage: http://github.com/rubik/stack-hpc-coveralls @@ -17,8 +17,7 @@ library hs-source-dirs: src - exposed-modules: SHC - other-modules: SHC.Coveralls + exposed-modules: SHC.Coverage SHC.Types SHC.Utils SHC.Lix @@ -33,16 +32,13 @@ , bytestring >=0.10 , utf8-string >=1 , text >=1.2 - , directory >=1.2 - , directory-tree >=0.12 , wreq >=0.3 , http-client >=0.4 , lens >=4.7 , lens-aeson >=1.0 - , safe >=0.3 default-language: Haskell2010 -executable stack-hpc-coveralls +executable shc hs-source-dirs: app main-is: Main.hs ghc-options: -Wall @@ -53,13 +49,22 @@ , stack-hpc-coveralls -any default-language: Haskell2010 -test-suite stack-hpc-coveralls-test +test-suite shc-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + other-modules: SHCSpec + SHCHUnits build-depends: base >=4.7 && <5 , stack-hpc-coveralls -any , hspec >=2.1 + , hspec-contrib >=0.3 + , HUnit >=1.2 + , hpc >=0.6 + , containers >=0.5 + , deepseq >=1.3 + , aeson >=0.8 + , time >=1.4 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/test/SHCHUnits.hs b/test/SHCHUnits.hs new file mode 100644 --- /dev/null +++ b/test/SHCHUnits.hs @@ -0,0 +1,171 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module SHCHUnits + where + +import Test.HUnit +import Trace.Hpc.Mix +import Trace.Hpc.Util + +import SHC.Lix +import SHC.Types +import SHC.Utils + + +(~::) :: String -> [Assertion] -> Test +label ~:: tests = TestList $ + zipWith (\i -> TestLabel $ label ++ " " ++ show i) [1..] (map TestCase tests) + +boxes :: [MixEntry] +boxes = [ (undefined, ExpBox False) + , (undefined, BinBox GuardBinBox True) + , (undefined, BinBox GuardBinBox False) + ] + +boxes2 :: [MixEntry] +boxes2 = map (\(_, b) -> (toHpcPos (1, 1, 1, 2), b)) boxes + +testToHit :: Test +testToHit = "toHit" ~:: + [ Irrelevant @=? toHit [] + , None @=? toHit [False] + , None @=? toHit [False, False] + , Partial @=? toHit [False, True] + , Partial @=? toHit [True, False] + , Partial @=? toHit [False, False, True] + , Partial @=? toHit [False, True, False] + , Partial @=? toHit [True, False, False] + , Full @=? toHit [True] + , Full @=? toHit [True, True] + ] + +testToLineHit :: Test +testToLineHit = "toLineHit" ~:: + [ toLineHit ( [(toHpcPos (4, 5, 6, 2), undefined)] + , [], undefined) @?= (3, True) + , toLineHit ( [(toHpcPos (4, 5, 6, 2), undefined)] + , [1], undefined) @?= (3, True) + , toLineHit ( [(toHpcPos (4, 5, 6, 2), undefined)] + , [0], undefined) @?= (3, False) + , toLineHit ( [(toHpcPos (4, 5, 6, 2), undefined)] + , [0, 1], undefined) @?= (3, False) + ] + +testIsOtherwiseEntry :: Test +testIsOtherwiseEntry = "testIsOtherwiseEntry" ~:: + [ isOtherwiseEntry ([], undefined, []) @?= False + , isOtherwiseEntry ([], undefined, ["otherwise"]) @?= False + , isOtherwiseEntry (boxes, undefined, []) @?= False + , isOtherwiseEntry (boxes, undefined, ["otherwise"]) @?= True + ] + +testAdjust :: Test +testAdjust = "testAdjust" ~:: + [ adjust (boxes2, [], ["otherwise"]) @?= (boxes2, [], ["otherwise"]) + , adjust (boxes2, [0], ["otherwise"]) @?= (boxes2, [0], ["otherwise"]) + , adjust (boxes2, [1], ["otherwise"]) @?= (boxes2, [1, 1, 1], ["otherwise"]) + , adjust ([], [0], ["otherwise"]) @?= ([], [0], ["otherwise"]) + , adjust ([], [0], []) @?= ([], [0], []) + ] + + + +testMcons :: Test +testMcons = "mcons" ~:: + [ mcons Nothing [] @?= ([]::[Int]) + , mcons (Just 2) [] @?= [2] + , mcons Nothing [4] @?= [4] + , mcons (Just 4) [2] @?= [4, 2] + ] + +testMatchAny :: Test +testMatchAny = "matchAny" ~:: + [ matchAny [] "" @?= False + , matchAny [] "test" @?= False + , matchAny ["nothing"] "something" @?= False + , matchAny ["a"] "also" @?= True + , matchAny ["a", "b"] "beta" @?= True + , matchAny ["a", "c"] "gamma" @?= False + ] + +testMapFirst :: Test +testMapFirst = "mapFirst" ~:: + [ mapFirst (+ 1) [] @?= [] + , mapFirst (+ 1) [2] @?= [3] + , mapFirst (+ 1) [2, 3] @?= [3, 3] + , mapFirst (+ 1) [2, 3, 5] @?= [3, 3, 5] + ] + +testMapLast :: Test +testMapLast = "mapLast" ~:: + [ mapLast (+ 1) [] @?= [] + , mapLast (+ 1) [2] @?= [3] + , mapLast (+ 1) [2, 3] @?= [2, 4] + , mapLast (+ 1) [2, 3, 5] @?= [2, 3, 6] + ] + +testSubSeq :: Test +testSubSeq = "subSeq" ~:: + [ subSeq 0 0 [] @?= ([] :: [Int]) + , subSeq 0 0 [2] @?= [] + , subSeq 0 1 [2] @?= [2] + , subSeq 0 2 [2] @?= [2] + , subSeq 1 1 [2] @?= [] + , subSeq 1 2 [2] @?= [] + , subSeq 0 0 [2, 3] @?= [] + , subSeq 0 1 [2, 3] @?= [2] + , subSeq 0 2 [2, 3] @?= [2, 3] + , subSeq 0 3 [2, 3] @?= [2, 3] + , subSeq 1 1 [2, 3] @?= [] + , subSeq 1 2 [2, 3] @?= [3] + , subSeq 1 3 [2, 3] @?= [3] + , subSeq 0 2 [2, 3] @?= [2, 3] + , subSeq 1 3 [2, 3, 5] @?= [3, 5] + , subSeq 0 3 [2, 3, 5] @?= [2, 3, 5] + ] + +testSubSubSeq :: Test +testSubSubSeq = "subSubSeq" ~:: + [ subSubSeq 0 0 [[]] @?= ([[]] :: [[Int]]) + , subSubSeq 0 0 [[2]] @?= [[]] + , subSubSeq 0 1 [[2]] @?= [[2]] + , subSubSeq 0 0 [[2, 3]] @?= [[]] + , subSubSeq 0 1 [[2, 3]] @?= [[2]] + , subSubSeq 0 2 [[2, 3]] @?= [[2, 3]] + , subSubSeq 1 1 [[2, 3]] @?= [[]] + , subSubSeq 1 2 [[2, 3]] @?= [[3]] + , subSubSeq 1 3 [[2, 3]] @?= [[3]] + , subSubSeq 0 2 [[2, 3]] @?= [[2, 3]] + , subSubSeq 1 3 [[2, 3, 5]] @?= [[3, 5]] + , subSubSeq 0 3 [[2, 3, 5]] @?= [[2, 3, 5]] + , subSubSeq 0 0 [[2, 3], [5, 7]] @?= [[2, 3], []] + , subSubSeq 0 1 [[2, 3], [5, 7]] @?= [[2, 3], [5]] + , subSubSeq 0 2 [[2, 3], [5, 7]] @?= [[2, 3], [5, 7]] + , subSubSeq 1 0 [[2, 3], [5, 7]] @?= [[3], []] + , subSubSeq 1 1 [[2, 3], [5, 7]] @?= [[3], [5]] + , subSubSeq 1 2 [[2, 3], [5, 7]] @?= [[3], [5, 7]] + , subSubSeq 2 0 [[2, 3], [5, 7]] @?= [[], []] + , subSubSeq 2 1 [[2, 3], [5, 7]] @?= [[], [5]] + , subSubSeq 2 2 [[2, 3], [5, 7]] @?= [[], [5, 7]] + ] + +testGroupByIndex :: Test +testGroupByIndex = "groupByIndex" ~:: + [ groupByIndex 0 [(0, 2)] @?= [] + , groupByIndex 1 [(0, 2)] @?= [[2]] + , groupByIndex 2 [(0, 2)] @?= [[2], []] + , groupByIndex 0 [(1, 2)] @?= [] + , groupByIndex 1 [(1, 2)] @?= [[]] + , groupByIndex 2 [(1, 2)] @?= [[], [2]] + , groupByIndex 3 [(1, 2)] @?= [[], [2], []] + , groupByIndex 0 [(0, 2), (0, 3)] @?= [] + , groupByIndex 1 [(0, 2), (0, 3)] @?= [[3, 2]] + , groupByIndex 1 [(0, 2), (1, 3)] @?= [[2]] + , groupByIndex 1 [(1, 2), (1, 3)] @?= [[]] + , groupByIndex 2 [(0, 2), (0, 3)] @?= [[3, 2], []] + , groupByIndex 2 [(0, 2), (1, 3)] @?= [[2], [3]] + , groupByIndex 2 [(1, 2), (1, 3)] @?= [[], [3, 2]] + , groupByIndex 3 [(0, 2), (0, 3)] @?= [[3, 2], [], []] + , groupByIndex 3 [(0, 2), (1, 3)] @?= [[2], [3], []] + , 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]] + ] diff --git a/test/SHCSpec.hs b/test/SHCSpec.hs new file mode 100644 --- /dev/null +++ b/test/SHCSpec.hs @@ -0,0 +1,111 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +module SHCSpec (spec) + where + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Data.Aeson +import qualified Data.Map.Strict as M +import Data.Time.Clock (getCurrentTime) +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec +import Test.Hspec.Contrib.HUnit +import Trace.Hpc.Mix +import Trace.Hpc.Util + +import SHCHUnits + +import SHC.Api +import SHC.Coverage +import SHC.Lix +import SHC.Types +import SHC.Utils + +#if __GLASGOW_HASKELL__ < 710 +deriving instance Eq Mix +#endif + + +covEntries :: [CoverageEntry] +covEntries = + [ ([(toHpcPos (1, 2, 3, 4), ExpBox True)], [1, 2, 3, 0, 1, 4], ["a"]) + , ([(toHpcPos (1, 2, 3, 8), ExpBox True)], [1, 2, 3, 3, 1, 4], ["a"]) + , ([(toHpcPos (2, 5, 6, 7), ExpBox True)], [1, 2, 3, 4, 2, 4], ["b"]) + , ([(toHpcPos (4, 8, 9, 9), ExpBox True)], [0], ["c"]) + ] + +mix :: Mix +mix = Mix undefined undefined undefined undefined boxes2 + +mix2 :: Mix +mix2 = Mix "path" (unsafePerformIO getCurrentTime) (toHash 'c') 3 boxes2 + +spec :: Spec +spec = do + describe "SHC.Coverage" $ do + describe "toSimpleCoverage" $ do + it "works with strictConverter" $ + toSimpleCoverage strictConverter 4 covEntries `shouldBe` + [Number 0, Number 1, Null, Number 0] + it "works with looseConverter" $ + toSimpleCoverage looseConverter 4 covEntries `shouldBe` + [Number 1, Number 2, Null, Number 0] + describe "coverageToJson" $ + it "works with standard coverage data" $ + coverageToJson strictConverter "path" + ("a\nb\nc\n", mix, [1, 2, 3]) + `shouldBe` + object [ "name" .= ("path"::String) + , "source_digest" .= ("40c53c58fdafacc83cfff6ee3d2f6d69"::String) + , "coverage" .= [Number 1, Null, Null] + ] + describe "mergeCoverageData" $ + it "works with standard coverage data" $ + mergeCoverageData + [ M.fromList [ ("path1", ("", mix2, [1, 2, 3])) + , ("path2", ("a", mix2, [4, 5, 6])) + ] + , M.fromList [("path1", ("c", mix2, [8, 1, 3]))] + ] + `shouldBe` M.fromList [ ("path1", ("", mix2, [9, 3, 6])) + , ("path2", ("a", mix2, [4, 5, 6])) + ] + describe "SHC.Lix" $ do + describe "toHit" $ + fromHUnitTest testToHit + it "startLine" $ + startLine (toHpcPos (1, 2, 3, 4), undefined) `shouldBe` 1 + describe "toLineHit" $ do + it "throws an exception with empty lists" $ + evaluate (force (toLineHit ([], [], [""]))) `shouldThrow` anyException + fromHUnitTest testToLineHit + describe "isOtherwiseEntry" $ + fromHUnitTest testIsOtherwiseEntry + describe "adjust" $ + fromHUnitTest testAdjust + it "toLix" $ + toLix 4 covEntries `shouldBe` [Partial, Full, Irrelevant, None] + describe "SHC.Utils" $ do + it "fst3" $ fst3 (1, 2, 3) `shouldBe` 1 + it "snd3" $ snd3 (1, 2, 3) `shouldBe` 2 + it "trd3" $ trd3 (1, 2, 3) `shouldBe` 3 + it "fst4" $ fst4 (1, 2, 3, 4) `shouldBe` 1 + it "toFirstAndRest" $ + toFirstAndRest (1, 2, 3, 4) `shouldBe` (1, (2, 3, 4)) + describe "mcons" $ + fromHUnitTest testMcons + describe "matchAny" $ + fromHUnitTest testMatchAny + describe "mapFirst" $ + fromHUnitTest testMapFirst + describe "mapLast" $ + fromHUnitTest testMapLast + describe "subSeq" $ + fromHUnitTest testSubSeq + describe "subSubSeq" $ + fromHUnitTest testSubSubSeq + describe "groupByIndex" $ + fromHUnitTest testGroupByIndex diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,1 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}