{-# 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)

-- | Logs all test results for a package, broken down first by test suite and
-- then by test case.
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]
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
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
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)

-- | A 'PackageLog' with package and platform information specified.
localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog
localPackageLog :: PackageDescription -> LocalBuildInfo -> PackageLog
localPackageLog PackageDescription
pkg_descr LocalBuildInfo
lbi = PackageLog
    { package :: PackageId
package = PackageDescription -> PackageId
PD.package PackageDescription
pkg_descr
    , compiler :: CompilerId
compiler = Compiler -> CompilerId
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 = []
    }

-- | Logs test suite results, itemized by test case.
data TestSuiteLog = TestSuiteLog
    { TestSuiteLog -> UnqualComponentName
testSuiteName :: UnqualComponentName
    , TestSuiteLog -> TestLogs
testLogs :: TestLogs
    , TestSuiteLog -> String
logFile :: FilePath    -- path to human-readable log file
    }
    deriving (ReadPrec [TestSuiteLog]
ReadPrec TestSuiteLog
Int -> ReadS TestSuiteLog
ReadS [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
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
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]
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
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
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)

-- | Count the number of pass, fail, and error test results in a 'TestLogs'
-- tree.
countTestResults :: TestLogs
                 -> (Int, Int, Int) -- ^ Passes, fails, and errors,
                                    -- respectively.
countTestResults :: TestLogs -> (Int, Int, Int)
countTestResults = 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 forall a. Num a => a -> a -> a
+ a
1, b
f, c
e)
            Fail String
_ -> (a
p, b
f forall a. Num a => a -> a -> a
+ b
1, c
e)
            Error String
_ -> (a
p, b
f, c
e forall a. Num a => a -> a -> a
+ c
1)
    go (a
p, b
f, c
e) (GroupLogs String
_ [TestLogs]
ts) = 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

-- | From a 'TestSuiteLog', determine if the test suite passed.
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

-- | From a 'TestSuiteLog', determine if the test suite failed.
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

-- | From a 'TestSuiteLog', determine if the test suite encountered errors.
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 -- ^ test suite name
                 -> TestLogs -- ^ test suite results
                 -> FilePath
testSuiteLogPath :: PathTemplate
-> PackageDescription
-> LocalBuildInfo
-> String
-> TestLogs
-> String
testSuiteLogPath PathTemplate
template PackageDescription
pkg_descr LocalBuildInfo
lbi String
test_name TestLogs
result =
    PathTemplate -> String
fromPathTemplate 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 forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
LBI.compiler LocalBuildInfo
lbi) (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
                forall a. [a] -> [a] -> [a]
++  [ (PathTemplateVariable
TestSuiteNameVar, String -> PathTemplate
toPathTemplate String
test_name)
                    , (PathTemplateVariable
TestSuiteResultVar, String -> PathTemplate
toPathTemplate forall a b. (a -> b) -> a -> b
$ TestLogs -> String
resultString TestLogs
result)
                    ]

-- | Print a summary to the console after all test suites have been run
-- indicating the number of successful test suites and cases.  Returns 'True' if
-- all test suites passed and 'False' otherwise.
summarizePackage :: Verbosity -> PackageLog -> IO Bool
summarizePackage :: Verbosity -> PackageLog -> IO Bool
summarizePackage Verbosity
verbosity PackageLog
packageLog = do
    let counts :: [(Int, Int, Int)]
counts = forall a b. (a -> b) -> [a] -> [b]
map (TestLogs -> (Int, Int, Int)
countTestResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuiteLog -> TestLogs
testLogs) forall a b. (a -> b) -> a -> b
$ PackageLog -> [TestSuiteLog]
testSuites PackageLog
packageLog
        (Int
passed, Int
failed, Int
errors) = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
Prelude.foldl1 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 forall a. Num a => a -> a -> a
+ Int
failed forall a. Num a => a -> a -> a
+ Int
errors
        passedSuites :: Int
passedSuites = forall (t :: * -> *) a. Foldable t => t a -> Int
length
                       forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (TestLogs -> Bool
suitePassed forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuiteLog -> TestLogs
testLogs)
                       forall a b. (a -> b) -> a -> b
$ PackageLog -> [TestSuiteLog]
testSuites PackageLog
packageLog
        totalSuites :: Int
totalSuites = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ PackageLog -> [TestSuiteLog]
testSuites PackageLog
packageLog
    Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
passedSuites forall a. [a] -> [a] -> [a]
++ String
" of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
totalSuites
        forall a. [a] -> [a] -> [a]
++ String
" test suites (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
passed forall a. [a] -> [a] -> [a]
++ String
" of "
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
totalCases forall a. [a] -> [a] -> [a]
++ String
" test cases) passed."
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Int
passedSuites 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 forall a. Num a => a -> a -> a
+ a
p2, b
f1 forall a. Num a => a -> a -> a
+ b
f2, c
e1 forall a. Num a => a -> a -> a
+ c
e2)

-- | Print a summary of a single test case's result to the console, suppressing
-- output for certain verbosity or test filter levels.
summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()
summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()
summarizeTest Verbosity
_ TestShowDetails
_ (GroupLogs {}) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
summarizeTest Verbosity
verbosity TestShowDetails
details TestLogs
t =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldPrint forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Test case " forall a. [a] -> [a] -> [a]
++ TestLogs -> String
testName TestLogs
t
        forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (TestLogs -> Result
testResult TestLogs
t)
    where shouldPrint :: Bool
shouldPrint = (TestShowDetails
details forall a. Ord a => a -> a -> Bool
> TestShowDetails
Never) Bool -> Bool -> Bool
&& (Bool
notPassed Bool -> Bool -> Bool
|| TestShowDetails
details forall a. Eq a => a -> a -> Bool
== TestShowDetails
Always)
          notPassed :: Bool
notPassed = TestLogs -> Result
testResult TestLogs
t forall a. Eq a => a -> a -> Bool
/= Result
Pass

-- | Print a summary of the test suite's results on the console, suppressing
-- output for certain verbosity or test filter levels.
summarizeSuiteFinish :: TestSuiteLog -> String
summarizeSuiteFinish :: TestSuiteLog -> String
summarizeSuiteFinish TestSuiteLog
testLog = [String] -> String
unlines
    [ String
"Test suite " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow (TestSuiteLog -> UnqualComponentName
testSuiteName TestSuiteLog
testLog) forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
resStr
    , String
"Test suite logged to: " forall a. [a] -> [a] -> [a]
++ TestSuiteLog -> String
logFile TestSuiteLog
testLog
    ]
    where resStr :: String
resStr = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (TestLogs -> String
resultString forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> TestLogs
testLogs TestSuiteLog
testLog)

summarizeSuiteStart :: String -> String
summarizeSuiteStart :: ShowS
summarizeSuiteStart String
n = String
"Test suite " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
": RUNNING...\n"