{-# 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
import Data.Aeson
import Data.Aeson.Types ()
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Digest.Pure.MD5
import Data.Function
import Data.List
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as M
import SHC.Lix
import SHC.Types
import SHC.Utils
import System.Exit (exitFailure)
import System.FilePath ((</>), normalise)
import Trace.Hpc.Mix
import Trace.Hpc.Tix
import Trace.Hpc.Util
type ModuleCoverageData = ( BS.ByteString -- 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
-- | 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
coverageData <- mapM getCoverageData tixs
let filteredCoverageData = filter sourceDirFilter coverageData
return $ M.fromList $ map toFirstAndRest filteredCoverageData
where getCoverageData tixModule@(TixModule modName _ _ tixs) = do
let pkgKey = takeWhile (/= '/') modName
stackProj =
fromMaybe (error $ "readCoverageData/filePath/stackProj: couldn't find " ++ pkgKey) $
find ((== pkgKey) . stackProjectKey) (stackProjects conf)
mix@(Mix origFp _ _ _ _) <- readMix [fromMaybe (stackProjectMixDir stackProj) (mixDir conf)] (Right tixModule)
let fp = normalise $ maybe id (</>) (stackProjectPath stackProj) origFp
source <- BS.readFile fp
return (fp, source, mix, tixs)
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.fromStrict) source
, "coverage" .= coverage
]
where coverage = toSimpleCoverage converter lineCount mixEntriesTixs
sourceLines = BS.lines source
lineCount = length sourceLines
mixEntriesTixs = groupMixEntryTixs mixEntryTixs
mixEntryTixs = zip3 mixEntries tixs (map getExprSource' mixEntries)
Mix _ _ _ _ mixEntries = mix
getExprSource' = getExprSource $ map BS.unpack sourceLines
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"