Cabal/src/Distribution/Simple/Test.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE RankNTypes #-}
   3
   4 -----------------------------------------------------------------------------
   5
   6 -- |
   7 -- Module      :  Distribution.Simple.Test
   8 -- Copyright   :  Thomas Tuegel 2010
   9 -- License     :  BSD3
  10 --
  11 -- Maintainer  :  cabal-devel@haskell.org
  12 -- Portability :  portable
  13 --
  14 -- This is the entry point into testing a built package. It performs the
  15 -- \"@.\/setup test@\" action. It runs test suites designated in the package
  16 -- description and reports on the results.
  17 module Distribution.Simple.Test
  18   ( test
  19   ) where
  20
  21 import Distribution.Compat.Prelude
  22 import Prelude ()
  23
  24 import qualified Distribution.PackageDescription as PD
  25 import Distribution.Pretty
  26 import Distribution.Simple.Compiler
  27 import Distribution.Simple.Flag (fromFlag)
  28 import Distribution.Simple.Hpc
  29 import Distribution.Simple.InstallDirs
  30 import qualified Distribution.Simple.LocalBuildInfo as LBI
  31 import Distribution.Simple.Setup.Test
  32 import qualified Distribution.Simple.Test.ExeV10 as ExeV10
  33 import qualified Distribution.Simple.Test.LibV09 as LibV09
  34 import Distribution.Simple.Test.Log
  35 import Distribution.Simple.UserHooks
  36 import Distribution.Simple.Utils
  37 import Distribution.TestSuite
  38 import qualified Distribution.Types.LocalBuildInfo as LBI
  39 import Distribution.Types.UnqualComponentName
  40
  41 import Distribution.Simple.Errors
  42 import System.Directory
  43   ( createDirectoryIfMissing
  44   , doesFileExist
  45   , getDirectoryContents
  46   , removeFile
  47   )
  48 import System.FilePath ((</>))
  49
  50 -- | Perform the \"@.\/setup test@\" action.
  51 test
  52   :: Args
  53   -- ^ positional command-line arguments
  54   -> PD.PackageDescription
  55   -- ^ information from the .cabal file
  56   -> LBI.LocalBuildInfo
  57   -- ^ information from the configure step
  58   -> TestFlags
  59   -- ^ flags sent to test
  60   -> IO ()
  61 test args pkg_descr lbi flags = do
  62   let verbosity = fromFlag $ testVerbosity flags
  63       machineTemplate = fromFlag $ testMachineLog flags
  64       distPref = fromFlag $ testDistPref flags
  65       testLogDir = distPref </> "test"
  66       testNames = args
  67       pkgTests = PD.testSuites pkg_descr
  68       enabledTests = LBI.enabledTestLBIs pkg_descr lbi
  69
  70       doTest
  71         :: ( (PD.TestSuite, LBI.ComponentLocalBuildInfo)
  72            , Maybe TestSuiteLog
  73            )
  74         -> IO TestSuiteLog
  75       doTest ((suite, clbi), _) =
  76         case PD.testInterface suite of
  77           PD.TestSuiteExeV10 _ _ ->
  78             ExeV10.runTest pkg_descr lbi clbi flags suite
  79           PD.TestSuiteLibV09 _ _ ->
  80             LibV09.runTest pkg_descr lbi clbi flags suite
  81           _ ->
  82             return
  83               TestSuiteLog
  84                 { testSuiteName = PD.testName suite
  85                 , testLogs =
  86                     TestLog
  87                       { testName = unUnqualComponentName $ PD.testName suite
  88                       , testOptionsReturned = []
  89                       , testResult =
  90                           Error $
  91                             "No support for running test suite type: "
  92                               ++ show (pretty $ PD.testType suite)
  93                       }
  94                 , logFile = ""
  95                 }
  96
  97   unless (PD.hasTests pkg_descr) $ do
  98     notice verbosity "Package has no test suites."
  99     exitSuccess
 100
 101   when (PD.hasTests pkg_descr && null enabledTests) $
 102     dieWithException verbosity NoTestSuitesEnabled
 103
 104   testsToRun <- case testNames of
 105     [] -> return $ zip enabledTests $ repeat Nothing
 106     names -> for names $ \tName ->
 107       let testMap = zip enabledNames enabledTests
 108           enabledNames = map (PD.testName . fst) enabledTests
 109           allNames = map PD.testName pkgTests
 110           tCompName = mkUnqualComponentName tName
 111        in case lookup tCompName testMap of
 112             Just t -> return (t, Nothing)
 113             _
 114               | tCompName `elem` allNames ->
 115                   dieWithException verbosity $ TestNameDisabled tName
 116               | otherwise -> dieWithException verbosity $ NoSuchTest tName
 117
 118   createDirectoryIfMissing True testLogDir
 119
 120   -- Delete ordinary files from test log directory.
 121   getDirectoryContents testLogDir
 122     >>= filterM doesFileExist . map (testLogDir </>)
 123     >>= traverse_ removeFile
 124
 125   let totalSuites = length testsToRun
 126   notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."
 127   suites <- traverse doTest testsToRun
 128   let packageLog = (localPackageLog pkg_descr lbi){testSuites = suites}
 129       packageLogFile =
 130         (</>) testLogDir $
 131           packageLogPath machineTemplate pkg_descr lbi
 132   allOk <- summarizePackage verbosity packageLog
 133   writeFile packageLogFile $ show packageLog
 134
 135   when (LBI.testCoverage lbi) $
 136     markupPackage verbosity lbi distPref pkg_descr $
 137       map (fst . fst) testsToRun
 138
 139   unless allOk exitFailure
 140
 141 packageLogPath
 142   :: PathTemplate
 143   -> PD.PackageDescription
 144   -> LBI.LocalBuildInfo
 145   -> FilePath
 146 packageLogPath template pkg_descr lbi =
 147   fromPathTemplate $ substPathTemplate env template
 148   where
 149     env =
 150       initialPathTemplateEnv
 151         (PD.package pkg_descr)
 152         (LBI.localUnitId lbi)
 153         (compilerInfo $ LBI.compiler lbi)
 154         (LBI.hostPlatform lbi)