Cabal/src/Distribution/Simple/Test.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 {-# LANGUAGE ViewPatterns #-}
   5
   6 -----------------------------------------------------------------------------
   7
   8 -- |
   9 -- Module      :  Distribution.Simple.Test
  10 -- Copyright   :  Thomas Tuegel 2010
  11 -- License     :  BSD3
  12 --
  13 -- Maintainer  :  cabal-devel@haskell.org
  14 -- Portability :  portable
  15 --
  16 -- This is the entry point into testing a built package. It performs the
  17 -- \"@.\/setup test@\" action. It runs test suites designated in the package
  18 -- description and reports on the results.
  19 module Distribution.Simple.Test
  20   ( test
  21   ) where
  22
  23 import Distribution.Compat.Prelude
  24 import Prelude ()
  25
  26 import qualified Distribution.PackageDescription as PD
  27 import Distribution.Pretty
  28 import Distribution.Simple.Compiler
  29 import Distribution.Simple.Flag (fromFlag)
  30 import Distribution.Simple.Hpc
  31 import Distribution.Simple.InstallDirs
  32 import qualified Distribution.Simple.LocalBuildInfo as LBI
  33 import Distribution.Simple.Setup.Test
  34 import qualified Distribution.Simple.Test.ExeV10 as ExeV10
  35 import qualified Distribution.Simple.Test.LibV09 as LibV09
  36 import Distribution.Simple.Test.Log
  37 import Distribution.Simple.UserHooks
  38 import Distribution.Simple.Utils
  39 import Distribution.TestSuite
  40 import qualified Distribution.Types.LocalBuildInfo as LBI
  41 import Distribution.Types.UnqualComponentName
  42
  43 import Distribution.Simple.Configure (getInstalledPackagesById)
  44 import Distribution.Simple.Errors
  45 import Distribution.Simple.Register
  46 import Distribution.Simple.Setup (fromFlagOrDefault)
  47 import Distribution.Simple.Setup.Common (extraCompilationArtifacts)
  48 import Distribution.Simple.Setup.Config
  49 import Distribution.Types.ExposedModule
  50 import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (libraryDirs), exposedModules)
  51 import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..))
  52 import System.Directory
  53   ( createDirectoryIfMissing
  54   , doesFileExist
  55   , getDirectoryContents
  56   , removeFile
  57   )
  58 import System.FilePath ((</>))
  59
  60 -- | Perform the \"@.\/setup test@\" action.
  61 test
  62   :: Args
  63   -- ^ positional command-line arguments
  64   -> PD.PackageDescription
  65   -- ^ information from the .cabal file
  66   -> LBI.LocalBuildInfo
  67   -- ^ information from the configure step
  68   -> TestFlags
  69   -- ^ flags sent to test
  70   -> IO ()
  71 test args pkg_descr lbi0 flags = do
  72   let verbosity = fromFlag $ testVerbosity flags
  73       machineTemplate = fromFlag $ testMachineLog flags
  74       distPref = fromFlag $ testDistPref flags
  75       testLogDir = distPref </> "test"
  76       testNames = args
  77       pkgTests = PD.testSuites pkg_descr
  78       enabledTests = LBI.enabledTestLBIs pkg_descr lbi
  79       -- We must add the internalPkgDB to the package database stack to lookup
  80       -- the path to HPC dirs of libraries local to this package
  81       internalPkgDB = internalPackageDBPath lbi distPref
  82       lbi = lbi0{withPackageDB = withPackageDB lbi0 ++ [SpecificPackageDB internalPkgDB]}
  83
  84       doTest
  85         :: HPCMarkupInfo
  86         -> ( (PD.TestSuite, LBI.ComponentLocalBuildInfo)
  87            , Maybe TestSuiteLog
  88            )
  89         -> IO TestSuiteLog
  90       doTest hpcMarkupInfo ((suite, clbi), _) =
  91         case PD.testInterface suite of
  92           PD.TestSuiteExeV10 _ _ ->
  93             ExeV10.runTest pkg_descr lbi clbi hpcMarkupInfo flags suite
  94           PD.TestSuiteLibV09 _ _ ->
  95             LibV09.runTest pkg_descr lbi clbi hpcMarkupInfo flags suite
  96           _ ->
  97             return
  98               TestSuiteLog
  99                 { testSuiteName = PD.testName suite
 100                 , testLogs =
 101                     TestLog
 102                       { testName = unUnqualComponentName $ PD.testName suite
 103                       , testOptionsReturned = []
 104                       , testResult =
 105                           Error $
 106                             "No support for running test suite type: "
 107                               ++ show (pretty $ PD.testType suite)
 108                       }
 109                 , logFile = ""
 110                 }
 111
 112   unless (PD.hasTests pkg_descr) $ do
 113     notice verbosity "Package has no test suites."
 114     exitSuccess
 115
 116   when (PD.hasTests pkg_descr && null enabledTests) $
 117     dieWithException verbosity NoTestSuitesEnabled
 118
 119   testsToRun <- case testNames of
 120     [] -> return $ zip enabledTests $ repeat Nothing
 121     names -> for names $ \tName ->
 122       let testMap = zip enabledNames enabledTests
 123           enabledNames = map (PD.testName . fst) enabledTests
 124           allNames = map PD.testName pkgTests
 125           tCompName = mkUnqualComponentName tName
 126        in case lookup tCompName testMap of
 127             Just t -> return (t, Nothing)
 128             _
 129               | tCompName `elem` allNames ->
 130                   dieWithException verbosity $ TestNameDisabled tName
 131               | otherwise -> dieWithException verbosity $ NoSuchTest tName
 132
 133   createDirectoryIfMissing True testLogDir
 134
 135   -- Delete ordinary files from test log directory.
 136   getDirectoryContents testLogDir
 137     >>= filterM doesFileExist . map (testLogDir </>)
 138     >>= traverse_ removeFile
 139
 140   -- We configured the unit-ids of libraries we should cover in our coverage
 141   -- report at configure time into the local build info. At build time, we built
 142   -- the hpc artifacts into the extraCompilationArtifacts directory, which, at
 143   -- install time, is copied into the ghc-pkg database files.
 144   -- Now, we get the path to the HPC artifacts and exposed modules of each
 145   -- library by querying the package database keyed by unit-id:
 146   let coverageFor =
 147         nub $
 148           fromFlagOrDefault [] (configCoverageFor (configFlags lbi))
 149             <> extraCoverageFor lbi
 150   ipkginfos <- getInstalledPackagesById verbosity lbi MissingCoveredInstalledLibrary coverageFor
 151   let ( concat -> pathsToLibsArtifacts
 152         , concat -> libsModulesToInclude
 153         ) =
 154           unzip $
 155             map
 156               ( \ip ->
 157                   ( map (</> extraCompilationArtifacts) $ libraryDirs ip
 158                   , map exposedName $ exposedModules ip
 159                   )
 160               )
 161               ipkginfos
 162       hpcMarkupInfo = HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude}
 163
 164   let totalSuites = length testsToRun
 165   notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."
 166   suites <- traverse (doTest hpcMarkupInfo) testsToRun
 167   let packageLog = (localPackageLog pkg_descr lbi){testSuites = suites}
 168       packageLogFile =
 169         (</>) testLogDir $
 170           packageLogPath machineTemplate pkg_descr lbi
 171   allOk <- summarizePackage verbosity packageLog
 172   writeFile packageLogFile $ show packageLog
 173
 174   when (LBI.testCoverage lbi) $
 175     markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr $
 176       map (fst . fst) testsToRun
 177
 178   unless allOk exitFailure
 179
 180 packageLogPath
 181   :: PathTemplate
 182   -> PD.PackageDescription
 183   -> LBI.LocalBuildInfo
 184   -> FilePath
 185 packageLogPath template pkg_descr lbi =
 186   fromPathTemplate $ substPathTemplate env template
 187   where
 188     env =
 189       initialPathTemplateEnv
 190         (PD.package pkg_descr)
 191         (LBI.localUnitId lbi)
 192         (compilerInfo $ LBI.compiler lbi)
 193         (LBI.hostPlatform lbi)