module Distribution.Simple.Test.Log
( PackageLog(..)
, TestLogs(..)
, TestSuiteLog(..)
, countTestResults
, localPackageLog
, summarizePackage
, summarizeSuiteFinish, summarizeSuiteStart
, summarizeTest
, suiteError, suiteFailed, suitePassed
, testSuiteLogPath
) where
import Distribution.Package ( PackageId )
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Compiler ( Compiler(..), compilerInfo, CompilerId )
import Distribution.Simple.InstallDirs
( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
, substPathTemplate , toPathTemplate, PathTemplate )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Setup ( TestShowDetails(..) )
import Distribution.Simple.Utils ( notice )
import Distribution.System ( Platform )
import Distribution.TestSuite ( Options, Result(..) )
import Distribution.Verbosity ( Verbosity )
import Control.Monad ( when )
import Data.Char ( toUpper )
data PackageLog = PackageLog
{ package :: PackageId
, compiler :: CompilerId
, platform :: Platform
, testSuites :: [TestSuiteLog]
}
deriving (Read, Show, Eq)
localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog
localPackageLog pkg_descr lbi = PackageLog
{ package = PD.package pkg_descr
, compiler = compilerId $ LBI.compiler lbi
, platform = LBI.hostPlatform lbi
, testSuites = []
}
data TestSuiteLog = TestSuiteLog
{ testSuiteName :: String
, testLogs :: TestLogs
, logFile :: FilePath
}
deriving (Read, Show, Eq)
data TestLogs
= TestLog
{ testName :: String
, testOptionsReturned :: Options
, testResult :: Result
}
| GroupLogs String [TestLogs]
deriving (Read, Show, Eq)
countTestResults :: TestLogs
-> (Int, Int, Int)
countTestResults = go (0, 0, 0)
where
go (p, f, e) (TestLog { testResult = r }) =
case r of
Pass -> (p + 1, f, e)
Fail _ -> (p, f + 1, e)
Error _ -> (p, f, e + 1)
go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts
suitePassed :: TestLogs -> Bool
suitePassed l =
case countTestResults l of
(_, 0, 0) -> True
_ -> False
suiteFailed :: TestLogs -> Bool
suiteFailed l =
case countTestResults l of
(_, 0, _) -> False
_ -> True
suiteError :: TestLogs -> Bool
suiteError l =
case countTestResults l of
(_, _, 0) -> False
_ -> True
resultString :: TestLogs -> String
resultString l | suiteError l = "error"
| suiteFailed l = "fail"
| otherwise = "pass"
testSuiteLogPath :: PathTemplate
-> PD.PackageDescription
-> LBI.LocalBuildInfo
-> String
-> TestLogs
-> FilePath
testSuiteLogPath template pkg_descr lbi name result =
fromPathTemplate $ substPathTemplate env template
where
env = initialPathTemplateEnv
(PD.package pkg_descr) (LBI.pkgKey lbi)
(compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)
++ [ (TestSuiteNameVar, toPathTemplate name)
, (TestSuiteResultVar, toPathTemplate $ resultString result)
]
summarizePackage :: Verbosity -> PackageLog -> IO Bool
summarizePackage verbosity packageLog = do
let counts = map (countTestResults . testLogs) $ testSuites packageLog
(passed, failed, errors) = foldl1 addTriple counts
totalCases = passed + failed + errors
passedSuites = length
$ filter (suitePassed . testLogs)
$ testSuites packageLog
totalSuites = length $ testSuites packageLog
notice verbosity $ show passedSuites ++ " of " ++ show totalSuites
++ " test suites (" ++ show passed ++ " of "
++ show totalCases ++ " test cases) passed."
return $! passedSuites == totalSuites
where
addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2)
summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()
summarizeTest _ _ (GroupLogs {}) = return ()
summarizeTest verbosity details t =
when shouldPrint $ notice verbosity $ "Test case " ++ testName t
++ ": " ++ show (testResult t)
where shouldPrint = (details > Never) && (notPassed || details == Always)
notPassed = testResult t /= Pass
summarizeSuiteFinish :: TestSuiteLog -> String
summarizeSuiteFinish testLog = unlines
[ "Test suite " ++ testSuiteName testLog ++ ": " ++ resStr
, "Test suite logged to: " ++ logFile testLog
]
where resStr = map toUpper (resultString $ testLogs testLog)
summarizeSuiteStart :: String -> String
summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"