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