stack-hpc-coveralls 0.0.0.4 → 0.0.1.0
raw patch · 13 files changed
+596/−305 lines, 13 filesdep +HUnitdep +deepseqdep +hspec-contribdep −directorydep −directory-treedep −safenew-component:exe:shc
Dependencies added: HUnit, deepseq, hspec-contrib, time
Dependencies removed: directory, directory-tree, safe
Files
- USAGE.txt +7/−7
- app/Main.hs +31/−17
- src/SHC.hs +0/−17
- src/SHC/Api.hs +35/−27
- src/SHC/Coverage.hs +141/−0
- src/SHC/Coveralls.hs +0/−135
- src/SHC/Lix.hs +16/−18
- src/SHC/Types.hs +34/−33
- src/SHC/Utils.hs +36/−41
- stack-hpc-coveralls.cabal +13/−8
- test/SHCHUnits.hs +171/−0
- test/SHCSpec.hs +111/−0
- test/Spec.hs +1/−2
USAGE.txt view
@@ -1,10 +1,10 @@ Usage:- stack-hpc-coveralls [options] <package-name> <suite-name>+ shc [options] <package-name> <suite-name>... Options:- -h --help show this help- --hpc-dir=<path> base HPC directory- --mix-dir=<path> 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=<path> base HPC directory+ --mix-dir=<path> directory in which HPC stores mix files+ --repo-token=<token> Coveralls repo token+ --partial-coverage allow partial line coverage+ --dont-send display Coveralls JSON instead of sending it
app/Main.hs view
@@ -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
− src/SHC.hs
@@ -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
src/SHC/Api.hs view
@@ -1,24 +1,42 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: SHC.Lix+-- Copyright: (c) 2015 Michele Lacchia+-- License: ISC+-- Maintainer: Michele Lacchia <michelelacchia@gmail.com>+-- 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<strong>"---- | 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
+ src/SHC/Coverage.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: SHC.Coverage+-- Copyright: (c) 2015 Michele Lacchia+-- License: ISC+-- Maintainer: Michele Lacchia <michelelacchia@gmail.com>+-- 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"
− src/SHC/Coveralls.hs
@@ -1,135 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}---- |--- Module: SHC.Coveralls--- Copyright: (c) 2015 Michele Lacchia--- License: ISC--- Maintainer: Michele Lacchia <michelelacchia@gmail.com>--- 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
src/SHC/Lix.hs view
@@ -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
src/SHC/Types.hs view
@@ -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
src/SHC/Utils.hs view
@@ -1,21 +1,30 @@+{-# LANGUAGE CPP #-}+-- |+-- Module: SHC.Utils+-- Copyright: (c) 2014-2015 Guillaume Nargeot+-- License: BSD3+-- Maintainer: Michele Lacchia <michelelacchia@gmail.com>+-- 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
stack-hpc-coveralls.cabal view
@@ -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
+ test/SHCHUnits.hs view
@@ -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]]+ ]
+ test/SHCSpec.hs view
@@ -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
test/Spec.hs view
@@ -1,2 +1,1 @@-main :: IO ()-main = putStrLn "Test suite not yet implemented"+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}