Distribution/Simple/Test/Log.hs

    {-# 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.Text

    -- | Logs all test results for a package, broken down first by test suite and
    -- then by test case.
    data PackageLog = PackageLog
        { package :: PackageId
        , compiler :: CompilerId
        , platform :: Platform
        , testSuites :: [TestSuiteLog]
        }
        deriving (Read, Show, Eq)

    -- | A 'PackageLog' with package and platform information specified.
    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 = []
        }

    -- | Logs test suite results, itemized by test case.
    data TestSuiteLog = TestSuiteLog
        { testSuiteName :: UnqualComponentName
        , testLogs :: TestLogs
        , logFile :: FilePath    -- path to human-readable log file
        }
        deriving (Read, Show, Eq)

    data TestLogs
        = TestLog
            { testName              :: String
            , testOptionsReturned   :: Options
            , testResult            :: Result
            }
        | GroupLogs String [TestLogs]
        deriving (Read, Show, 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 = 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

    -- | From a 'TestSuiteLog', determine if the test suite passed.
    suitePassed :: TestLogs -> Bool
    suitePassed l =
        case countTestResults l of
            (_, 0, 0) -> True
            _ -> False

    -- | From a 'TestSuiteLog', determine if the test suite failed.
    suiteFailed :: TestLogs -> Bool
    suiteFailed l =
        case countTestResults l of
            (_, 0, _) -> False
            _ -> True

    -- | From a 'TestSuiteLog', determine if the test suite encountered errors.
    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 -- ^ test suite name
                     -> TestLogs -- ^ test suite results
                     -> FilePath
    testSuiteLogPath template pkg_descr lbi test_name result =
        fromPathTemplate $ substPathTemplate env template
        where
            env = initialPathTemplateEnv
                    (PD.package pkg_descr) (LBI.localUnitId lbi)
                    (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)
                    ++  [ (TestSuiteNameVar, toPathTemplate test_name)
                        , (TestSuiteResultVar, toPathTemplate $ resultString 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 = 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)

    -- | Print a summary of a single test case's result to the console, supressing
    -- output for certain verbosity or test filter levels.
    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

    -- | 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 testLog = unlines
        [ "Test suite " ++ display (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"