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

-- | 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 (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 = []
    }

-- | 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]
(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)

-- | 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 = (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

-- | 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 (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)
                    ]

-- | 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 = (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)

-- | 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 {}) = () -> 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

-- | 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 " 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"