Cabal/src/Distribution/Simple/Test/Log.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE RankNTypes #-}
   3
   4 module Distribution.Simple.Test.Log
   5   ( PackageLog (..)
   6   , TestLogs (..)
   7   , TestSuiteLog (..)
   8   , countTestResults
   9   , localPackageLog
  10   , summarizePackage
  11   , summarizeSuiteFinish
  12   , summarizeSuiteStart
  13   , summarizeTest
  14   , suiteError
  15   , suiteFailed
  16   , suitePassed
  17   , testSuiteLogPath
  18   ) where
  19
  20 import Distribution.Compat.Prelude
  21 import Prelude ()
  22
  23 import Distribution.Package
  24 import qualified Distribution.PackageDescription as PD
  25 import Distribution.Pretty
  26 import Distribution.Simple.Compiler
  27 import Distribution.Simple.InstallDirs
  28 import qualified Distribution.Simple.LocalBuildInfo as LBI
  29 import Distribution.Simple.Setup.Test (TestShowDetails (Always, Never))
  30 import Distribution.Simple.Utils
  31 import Distribution.System
  32 import Distribution.TestSuite
  33 import Distribution.Types.UnqualComponentName
  34 import Distribution.Verbosity
  35
  36 import qualified Prelude (foldl1)
  37
  38 -- | Logs all test results for a package, broken down first by test suite and
  39 -- then by test case.
  40 data PackageLog = PackageLog
  41   { package :: PackageId
  42   , compiler :: CompilerId
  43   , platform :: Platform
  44   , testSuites :: [TestSuiteLog]
  45   }
  46   deriving (Read, Show, Eq)
  47
  48 -- | A 'PackageLog' with package and platform information specified.
  49 localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog
  50 localPackageLog pkg_descr lbi =
  51   PackageLog
  52     { package = PD.package pkg_descr
  53     , compiler = compilerId $ LBI.compiler lbi
  54     , platform = LBI.hostPlatform lbi
  55     , testSuites = []
  56     }
  57
  58 -- | Logs test suite results, itemized by test case.
  59 data TestSuiteLog = TestSuiteLog
  60   { testSuiteName :: UnqualComponentName
  61   , testLogs :: TestLogs
  62   , logFile :: FilePath -- path to human-readable log file
  63   }
  64   deriving (Read, Show, Eq)
  65
  66 data TestLogs
  67   = TestLog
  68       { testName :: String
  69       , testOptionsReturned :: Options
  70       , testResult :: Result
  71       }
  72   | GroupLogs String [TestLogs]
  73   deriving (Read, Show, Eq)
  74
  75 -- | Count the number of pass, fail, and error test results in a 'TestLogs'
  76 -- tree.
  77 countTestResults
  78   :: TestLogs
  79   -> (Int, Int, Int)
  80   -- ^ Passes, fails, and errors,
  81   -- respectively.
  82 countTestResults = go (0, 0, 0)
  83   where
  84     go (p, f, e) (TestLog{testResult = r}) =
  85       case r of
  86         Pass -> (p + 1, f, e)
  87         Fail _ -> (p, f + 1, e)
  88         Error _ -> (p, f, e + 1)
  89     go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts
  90
  91 -- | From a 'TestSuiteLog', determine if the test suite passed.
  92 suitePassed :: TestLogs -> Bool
  93 suitePassed l =
  94   case countTestResults l of
  95     (_, 0, 0) -> True
  96     _ -> False
  97
  98 -- | From a 'TestSuiteLog', determine if the test suite failed.
  99 suiteFailed :: TestLogs -> Bool
 100 suiteFailed l =
 101   case countTestResults l of
 102     (_, 0, _) -> False
 103     _ -> True
 104
 105 -- | From a 'TestSuiteLog', determine if the test suite encountered errors.
 106 suiteError :: TestLogs -> Bool
 107 suiteError l =
 108   case countTestResults l of
 109     (_, _, 0) -> False
 110     _ -> True
 111
 112 resultString :: TestLogs -> String
 113 resultString l
 114   | suiteError l = "error"
 115   | suiteFailed l = "fail"
 116   | otherwise = "pass"
 117
 118 testSuiteLogPath
 119   :: PathTemplate
 120   -> PD.PackageDescription
 121   -> LBI.LocalBuildInfo
 122   -> String
 123   -- ^ test suite name
 124   -> TestLogs
 125   -- ^ test suite results
 126   -> FilePath
 127 testSuiteLogPath template pkg_descr lbi test_name result =
 128   fromPathTemplate $ substPathTemplate env template
 129   where
 130     env =
 131       initialPathTemplateEnv
 132         (PD.package pkg_descr)
 133         (LBI.localUnitId lbi)
 134         (compilerInfo $ LBI.compiler lbi)
 135         (LBI.hostPlatform lbi)
 136         ++ [ (TestSuiteNameVar, toPathTemplate test_name)
 137            , (TestSuiteResultVar, toPathTemplate $ resultString result)
 138            ]
 139
 140 -- | Print a summary to the console after all test suites have been run
 141 -- indicating the number of successful test suites and cases.  Returns 'True' if
 142 -- all test suites passed and 'False' otherwise.
 143 summarizePackage :: Verbosity -> PackageLog -> IO Bool
 144 summarizePackage verbosity packageLog = do
 145   let counts = map (countTestResults . testLogs) $ testSuites packageLog
 146       (passed, failed, errors) = Prelude.foldl1 addTriple counts
 147       totalCases = passed + failed + errors
 148       passedSuites =
 149         length $
 150           filter (suitePassed . testLogs) $
 151             testSuites packageLog
 152       totalSuites = length $ testSuites packageLog
 153   notice verbosity $
 154     show passedSuites
 155       ++ " of "
 156       ++ show totalSuites
 157       ++ " test suites ("
 158       ++ show passed
 159       ++ " of "
 160       ++ show totalCases
 161       ++ " test cases) passed."
 162   return $! passedSuites == totalSuites
 163   where
 164     addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2)
 165
 166 -- | Print a summary of a single test case's result to the console, suppressing
 167 -- output for certain verbosity or test filter levels.
 168 summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()
 169 summarizeTest _ _ (GroupLogs{}) = return ()
 170 summarizeTest verbosity details t =
 171   when shouldPrint $
 172     notice verbosity $
 173       "Test case "
 174         ++ testName t
 175         ++ ": "
 176         ++ show (testResult t)
 177   where
 178     shouldPrint = (details > Never) && (notPassed || details == Always)
 179     notPassed = testResult t /= Pass
 180
 181 -- | Print a summary of the test suite's results on the console, suppressing
 182 -- output for certain verbosity or test filter levels.
 183 summarizeSuiteFinish :: TestSuiteLog -> String
 184 summarizeSuiteFinish testLog =
 185   unlines
 186     [ "Test suite " ++ prettyShow (testSuiteName testLog) ++ ": " ++ resStr
 187     , "Test suite logged to: " ++ logFile testLog
 188     ]
 189   where
 190     resStr = map toUpper (resultString $ testLogs testLog)
 191
 192 summarizeSuiteStart :: String -> String
 193 summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"