{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Test.Log
( PackageLog(..)
, TestLogs(..)
, TestSuiteLog(..)
, countTestResults
, localPackageLog
, summarizePackage
, summarizeSuiteFinish, summarizeSuiteStart
, summarizeTest
, suiteError, suiteFailed, suitePassed
, testSuiteLogPath
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Package
import Distribution.Types.UnqualComponentName
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Compiler
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Setup
import Distribution.Simple.Utils
import Distribution.System
import Distribution.TestSuite
import Distribution.Verbosity
import Distribution.Pretty
import qualified Prelude (foldl1)
data PackageLog = PackageLog
{ PackageLog -> PackageId
package :: PackageId
, PackageLog -> CompilerId
compiler :: CompilerId
, PackageLog -> Platform
platform :: Platform
, PackageLog -> [TestSuiteLog]
testSuites :: [TestSuiteLog]
}
deriving (ReadPrec [PackageLog]
ReadPrec PackageLog
Int -> ReadS PackageLog
ReadS [PackageLog]
(Int -> ReadS PackageLog)
-> ReadS [PackageLog]
-> ReadPrec PackageLog
-> ReadPrec [PackageLog]
-> Read PackageLog
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PackageLog]
$creadListPrec :: ReadPrec [PackageLog]
readPrec :: ReadPrec PackageLog
$creadPrec :: ReadPrec PackageLog
readList :: ReadS [PackageLog]
$creadList :: ReadS [PackageLog]
readsPrec :: Int -> ReadS PackageLog
$creadsPrec :: Int -> ReadS PackageLog
Read, Int -> PackageLog -> ShowS
[PackageLog] -> ShowS
PackageLog -> String
(Int -> PackageLog -> ShowS)
-> (PackageLog -> String)
-> ([PackageLog] -> ShowS)
-> Show PackageLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageLog] -> ShowS
$cshowList :: [PackageLog] -> ShowS
show :: PackageLog -> String
$cshow :: PackageLog -> String
showsPrec :: Int -> PackageLog -> ShowS
$cshowsPrec :: Int -> PackageLog -> ShowS
Show, PackageLog -> PackageLog -> Bool
(PackageLog -> PackageLog -> Bool)
-> (PackageLog -> PackageLog -> Bool) -> Eq PackageLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageLog -> PackageLog -> Bool
$c/= :: PackageLog -> PackageLog -> Bool
== :: PackageLog -> PackageLog -> Bool
$c== :: PackageLog -> PackageLog -> Bool
Eq)
localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog
localPackageLog :: PackageDescription -> LocalBuildInfo -> PackageLog
localPackageLog PackageDescription
pkg_descr LocalBuildInfo
lbi = PackageLog :: PackageId -> CompilerId -> Platform -> [TestSuiteLog] -> PackageLog
PackageLog
{ package :: PackageId
package = PackageDescription -> PackageId
PD.package PackageDescription
pkg_descr
, compiler :: CompilerId
compiler = Compiler -> CompilerId
compilerId (Compiler -> CompilerId) -> Compiler -> CompilerId
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
LBI.compiler LocalBuildInfo
lbi
, platform :: Platform
platform = LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi
, testSuites :: [TestSuiteLog]
testSuites = []
}
data TestSuiteLog = TestSuiteLog
{ TestSuiteLog -> UnqualComponentName
testSuiteName :: UnqualComponentName
, TestSuiteLog -> TestLogs
testLogs :: TestLogs
, TestSuiteLog -> String
logFile :: FilePath
}
deriving (ReadPrec [TestSuiteLog]
ReadPrec TestSuiteLog
Int -> ReadS TestSuiteLog
ReadS [TestSuiteLog]
(Int -> ReadS TestSuiteLog)
-> ReadS [TestSuiteLog]
-> ReadPrec TestSuiteLog
-> ReadPrec [TestSuiteLog]
-> Read TestSuiteLog
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TestSuiteLog]
$creadListPrec :: ReadPrec [TestSuiteLog]
readPrec :: ReadPrec TestSuiteLog
$creadPrec :: ReadPrec TestSuiteLog
readList :: ReadS [TestSuiteLog]
$creadList :: ReadS [TestSuiteLog]
readsPrec :: Int -> ReadS TestSuiteLog
$creadsPrec :: Int -> ReadS TestSuiteLog
Read, Int -> TestSuiteLog -> ShowS
[TestSuiteLog] -> ShowS
TestSuiteLog -> String
(Int -> TestSuiteLog -> ShowS)
-> (TestSuiteLog -> String)
-> ([TestSuiteLog] -> ShowS)
-> Show TestSuiteLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestSuiteLog] -> ShowS
$cshowList :: [TestSuiteLog] -> ShowS
show :: TestSuiteLog -> String
$cshow :: TestSuiteLog -> String
showsPrec :: Int -> TestSuiteLog -> ShowS
$cshowsPrec :: Int -> TestSuiteLog -> ShowS
Show, TestSuiteLog -> TestSuiteLog -> Bool
(TestSuiteLog -> TestSuiteLog -> Bool)
-> (TestSuiteLog -> TestSuiteLog -> Bool) -> Eq TestSuiteLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestSuiteLog -> TestSuiteLog -> Bool
$c/= :: TestSuiteLog -> TestSuiteLog -> Bool
== :: TestSuiteLog -> TestSuiteLog -> Bool
$c== :: TestSuiteLog -> TestSuiteLog -> Bool
Eq)
data TestLogs
= TestLog
{ TestLogs -> String
testName :: String
, TestLogs -> Options
testOptionsReturned :: Options
, TestLogs -> Result
testResult :: Result
}
| GroupLogs String [TestLogs]
deriving (ReadPrec [TestLogs]
ReadPrec TestLogs
Int -> ReadS TestLogs
ReadS [TestLogs]
(Int -> ReadS TestLogs)
-> ReadS [TestLogs]
-> ReadPrec TestLogs
-> ReadPrec [TestLogs]
-> Read TestLogs
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TestLogs]
$creadListPrec :: ReadPrec [TestLogs]
readPrec :: ReadPrec TestLogs
$creadPrec :: ReadPrec TestLogs
readList :: ReadS [TestLogs]
$creadList :: ReadS [TestLogs]
readsPrec :: Int -> ReadS TestLogs
$creadsPrec :: Int -> ReadS TestLogs
Read, Int -> TestLogs -> ShowS
[TestLogs] -> ShowS
TestLogs -> String
(Int -> TestLogs -> ShowS)
-> (TestLogs -> String) -> ([TestLogs] -> ShowS) -> Show TestLogs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestLogs] -> ShowS
$cshowList :: [TestLogs] -> ShowS
show :: TestLogs -> String
$cshow :: TestLogs -> String
showsPrec :: Int -> TestLogs -> ShowS
$cshowsPrec :: Int -> TestLogs -> ShowS
Show, TestLogs -> TestLogs -> Bool
(TestLogs -> TestLogs -> Bool)
-> (TestLogs -> TestLogs -> Bool) -> Eq TestLogs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestLogs -> TestLogs -> Bool
$c/= :: TestLogs -> TestLogs -> Bool
== :: TestLogs -> TestLogs -> Bool
$c== :: TestLogs -> TestLogs -> Bool
Eq)
countTestResults :: TestLogs
-> (Int, Int, Int)
countTestResults :: TestLogs -> (Int, Int, Int)
countTestResults = (Int, Int, Int) -> TestLogs -> (Int, Int, Int)
forall {a} {b} {c}.
(Num a, Num b, Num c) =>
(a, b, c) -> TestLogs -> (a, b, c)
go (Int
0, Int
0, Int
0)
where
go :: (a, b, c) -> TestLogs -> (a, b, c)
go (a
p, b
f, c
e) (TestLog { testResult :: TestLogs -> Result
testResult = Result
r }) =
case Result
r of
Result
Pass -> (a
p a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, b
f, c
e)
Fail String
_ -> (a
p, b
f b -> b -> b
forall a. Num a => a -> a -> a
+ b
1, c
e)
Error String
_ -> (a
p, b
f, c
e c -> c -> c
forall a. Num a => a -> a -> a
+ c
1)
go (a
p, b
f, c
e) (GroupLogs String
_ [TestLogs]
ts) = ((a, b, c) -> TestLogs -> (a, b, c))
-> (a, b, c) -> [TestLogs] -> (a, b, c)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (a, b, c) -> TestLogs -> (a, b, c)
go (a
p, b
f, c
e) [TestLogs]
ts
suitePassed :: TestLogs -> Bool
suitePassed :: TestLogs -> Bool
suitePassed TestLogs
l =
case TestLogs -> (Int, Int, Int)
countTestResults TestLogs
l of
(Int
_, Int
0, Int
0) -> Bool
True
(Int, Int, Int)
_ -> Bool
False
suiteFailed :: TestLogs -> Bool
suiteFailed :: TestLogs -> Bool
suiteFailed TestLogs
l =
case TestLogs -> (Int, Int, Int)
countTestResults TestLogs
l of
(Int
_, Int
0, Int
_) -> Bool
False
(Int, Int, Int)
_ -> Bool
True
suiteError :: TestLogs -> Bool
suiteError :: TestLogs -> Bool
suiteError TestLogs
l =
case TestLogs -> (Int, Int, Int)
countTestResults TestLogs
l of
(Int
_, Int
_, Int
0) -> Bool
False
(Int, Int, Int)
_ -> Bool
True
resultString :: TestLogs -> String
resultString :: TestLogs -> String
resultString TestLogs
l | TestLogs -> Bool
suiteError TestLogs
l = String
"error"
| TestLogs -> Bool
suiteFailed TestLogs
l = String
"fail"
| Bool
otherwise = String
"pass"
testSuiteLogPath :: PathTemplate
-> PD.PackageDescription
-> LBI.LocalBuildInfo
-> String
-> TestLogs
-> FilePath
testSuiteLogPath :: PathTemplate
-> PackageDescription
-> LocalBuildInfo
-> String
-> TestLogs
-> String
testSuiteLogPath PathTemplate
template PackageDescription
pkg_descr LocalBuildInfo
lbi String
test_name TestLogs
result =
PathTemplate -> String
fromPathTemplate (PathTemplate -> String) -> PathTemplate -> String
forall a b. (a -> b) -> a -> b
$ PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env PathTemplate
template
where
env :: PathTemplateEnv
env = PackageId -> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv
(PackageDescription -> PackageId
PD.package PackageDescription
pkg_descr) (LocalBuildInfo -> UnitId
LBI.localUnitId LocalBuildInfo
lbi)
(Compiler -> CompilerInfo
compilerInfo (Compiler -> CompilerInfo) -> Compiler -> CompilerInfo
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
LBI.compiler LocalBuildInfo
lbi) (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ [ (PathTemplateVariable
TestSuiteNameVar, String -> PathTemplate
toPathTemplate String
test_name)
, (PathTemplateVariable
TestSuiteResultVar, String -> PathTemplate
toPathTemplate (String -> PathTemplate) -> String -> PathTemplate
forall a b. (a -> b) -> a -> b
$ TestLogs -> String
resultString TestLogs
result)
]
summarizePackage :: Verbosity -> PackageLog -> IO Bool
summarizePackage :: Verbosity -> PackageLog -> IO Bool
summarizePackage Verbosity
verbosity PackageLog
packageLog = do
let counts :: [(Int, Int, Int)]
counts = (TestSuiteLog -> (Int, Int, Int))
-> [TestSuiteLog] -> [(Int, Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (TestLogs -> (Int, Int, Int)
countTestResults (TestLogs -> (Int, Int, Int))
-> (TestSuiteLog -> TestLogs) -> TestSuiteLog -> (Int, Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuiteLog -> TestLogs
testLogs) ([TestSuiteLog] -> [(Int, Int, Int)])
-> [TestSuiteLog] -> [(Int, Int, Int)]
forall a b. (a -> b) -> a -> b
$ PackageLog -> [TestSuiteLog]
testSuites PackageLog
packageLog
(Int
passed, Int
failed, Int
errors) = ((Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int))
-> [(Int, Int, Int)] -> (Int, Int, Int)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
Prelude.foldl1 (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
forall {a} {b} {c}.
(Num a, Num b, Num c) =>
(a, b, c) -> (a, b, c) -> (a, b, c)
addTriple [(Int, Int, Int)]
counts
totalCases :: Int
totalCases = Int
passed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
failed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
errors
passedSuites :: Int
passedSuites = [TestSuiteLog] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
([TestSuiteLog] -> Int) -> [TestSuiteLog] -> Int
forall a b. (a -> b) -> a -> b
$ (TestSuiteLog -> Bool) -> [TestSuiteLog] -> [TestSuiteLog]
forall a. (a -> Bool) -> [a] -> [a]
filter (TestLogs -> Bool
suitePassed (TestLogs -> Bool)
-> (TestSuiteLog -> TestLogs) -> TestSuiteLog -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuiteLog -> TestLogs
testLogs)
([TestSuiteLog] -> [TestSuiteLog])
-> [TestSuiteLog] -> [TestSuiteLog]
forall a b. (a -> b) -> a -> b
$ PackageLog -> [TestSuiteLog]
testSuites PackageLog
packageLog
totalSuites :: Int
totalSuites = [TestSuiteLog] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TestSuiteLog] -> Int) -> [TestSuiteLog] -> Int
forall a b. (a -> b) -> a -> b
$ PackageLog -> [TestSuiteLog]
testSuites PackageLog
packageLog
Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
passedSuites String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
totalSuites
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" test suites (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
passed String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" of "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
totalCases String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" test cases) passed."
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Int
passedSuites Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
totalSuites
where
addTriple :: (a, b, c) -> (a, b, c) -> (a, b, c)
addTriple (a
p1, b
f1, c
e1) (a
p2, b
f2, c
e2) = (a
p1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
p2, b
f1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
f2, c
e1 c -> c -> c
forall a. Num a => a -> a -> a
+ c
e2)
summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()
summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()
summarizeTest Verbosity
_ TestShowDetails
_ (GroupLogs {}) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
summarizeTest Verbosity
verbosity TestShowDetails
details TestLogs
t =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldPrint (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Test case " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TestLogs -> String
testName TestLogs
t
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Result -> String
forall a. Show a => a -> String
show (TestLogs -> Result
testResult TestLogs
t)
where shouldPrint :: Bool
shouldPrint = (TestShowDetails
details TestShowDetails -> TestShowDetails -> Bool
forall a. Ord a => a -> a -> Bool
> TestShowDetails
Never) Bool -> Bool -> Bool
&& (Bool
notPassed Bool -> Bool -> Bool
|| TestShowDetails
details TestShowDetails -> TestShowDetails -> Bool
forall a. Eq a => a -> a -> Bool
== TestShowDetails
Always)
notPassed :: Bool
notPassed = TestLogs -> Result
testResult TestLogs
t Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
/= Result
Pass
summarizeSuiteFinish :: TestSuiteLog -> String
summarizeSuiteFinish :: TestSuiteLog -> String
summarizeSuiteFinish TestSuiteLog
testLog = [String] -> String
unlines
[ String
"Test suite " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow (TestSuiteLog -> UnqualComponentName
testSuiteName TestSuiteLog
testLog) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
resStr
, String
"Test suite logged to: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TestSuiteLog -> String
logFile TestSuiteLog
testLog
]
where resStr :: String
resStr = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (TestLogs -> String
resultString (TestLogs -> String) -> TestLogs -> String
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> TestLogs
testLogs TestSuiteLog
testLog)
summarizeSuiteStart :: String -> String
summarizeSuiteStart :: ShowS
summarizeSuiteStart String
n = String
"Test suite " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": RUNNING...\n"