    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE ViewPatterns #-}

    -----------------------------------------------------------------------------

    -- |
    -- Module      :  Distribution.Simple.Test
    -- Copyright   :  Thomas Tuegel 2010
    -- License     :  BSD3
    --
    -- Maintainer  :  cabal-devel@haskell.org
    -- Portability :  portable
    --
    -- This is the entry point into testing a built package. It performs the
    -- \"@.\/setup test@\" action. It runs test suites designated in the package
    -- description and reports on the results.
    module Distribution.Simple.Test
      ( test
      ) where

    import Distribution.Compat.Prelude
    import Prelude ()

    import qualified Distribution.PackageDescription as PD
    import Distribution.Pretty
    import Distribution.Simple.Compiler
    import Distribution.Simple.Flag (fromFlag)
    import Distribution.Simple.Hpc
    import Distribution.Simple.InstallDirs
    import qualified Distribution.Simple.LocalBuildInfo as LBI
    import Distribution.Simple.Setup.Test
    import qualified Distribution.Simple.Test.ExeV10 as ExeV10
    import qualified Distribution.Simple.Test.LibV09 as LibV09
    import Distribution.Simple.Test.Log
    import Distribution.Simple.UserHooks
    import Distribution.Simple.Utils
    import Distribution.TestSuite
    import qualified Distribution.Types.LocalBuildInfo as LBI
    import Distribution.Types.UnqualComponentName

    import Distribution.Simple.Configure (getInstalledPackagesById)
    import Distribution.Simple.Errors
    import Distribution.Simple.Register
    import Distribution.Simple.Setup (fromFlagOrDefault)
    import Distribution.Simple.Setup.Common (extraCompilationArtifacts)
    import Distribution.Simple.Setup.Config
    import Distribution.Types.ExposedModule
    import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (libraryDirs), exposedModules)
    import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..))
    import System.Directory
      ( createDirectoryIfMissing
      , doesFileExist
      , getDirectoryContents
      , removeFile
      )
    import System.FilePath ((</>))

    -- | Perform the \"@.\/setup test@\" action.
    test
      :: Args
      -- ^ positional command-line arguments
      -> PD.PackageDescription
      -- ^ information from the .cabal file
      -> LBI.LocalBuildInfo
      -- ^ information from the configure step
      -> TestFlags
      -- ^ flags sent to test
      -> IO ()
    test :: Args -> PackageDescription -> LocalBuildInfo -> TestFlags -> IO ()
    test Args
    args PackageDescription
    pkg_descr LocalBuildInfo
    lbi0 TestFlags
    flags = do
      let verbosity :: Verbosity
    verbosity = Flag Verbosity -> Verbosity
    forall a. WithCallStack (Flag a -> a)
    fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
    forall a b. (a -> b) -> a -> b
    $ TestFlags -> Flag Verbosity
    testVerbosity TestFlags
    flags
          machineTemplate :: PathTemplate
    machineTemplate = Flag PathTemplate -> PathTemplate
    forall a. WithCallStack (Flag a -> a)
    fromFlag (Flag PathTemplate -> PathTemplate)
    -> Flag PathTemplate -> PathTemplate
    forall a b. (a -> b) -> a -> b
    $ TestFlags -> Flag PathTemplate
    testMachineLog TestFlags
    flags
          distPref :: FilePath
    distPref = Flag FilePath -> FilePath
    forall a. WithCallStack (Flag a -> a)
    fromFlag (Flag FilePath -> FilePath) -> Flag FilePath -> FilePath
    forall a b. (a -> b) -> a -> b
    $ TestFlags -> Flag FilePath
    testDistPref TestFlags
    flags
          testLogDir :: FilePath
    testLogDir = FilePath
    distPref FilePath -> FilePath -> FilePath
    </> FilePath
    "test"
          testNames :: Args
    testNames = Args
    args
          pkgTests :: [TestSuite]
    pkgTests = PackageDescription -> [TestSuite]
    PD.testSuites PackageDescription
    pkg_descr
          enabledTests :: [(TestSuite, ComponentLocalBuildInfo)]
    enabledTests = PackageDescription
    -> LocalBuildInfo -> [(TestSuite, ComponentLocalBuildInfo)]
    LBI.enabledTestLBIs PackageDescription
    pkg_descr LocalBuildInfo
    lbi
          -- We must add the internalPkgDB to the package database stack to lookup
          -- the path to HPC dirs of libraries local to this package
          internalPkgDB :: FilePath
    internalPkgDB = LocalBuildInfo -> FilePath -> FilePath
    internalPackageDBPath LocalBuildInfo
    lbi FilePath
    distPref
          lbi :: LocalBuildInfo
    lbi = LocalBuildInfo
    lbi0{withPackageDB = withPackageDB lbi0 ++ [SpecificPackageDB internalPkgDB]}

          doTest
            :: HPCMarkupInfo
            -> ( (PD.TestSuite, LBI.ComponentLocalBuildInfo)
               , Maybe TestSuiteLog
               )
            -> IO TestSuiteLog
          doTest :: HPCMarkupInfo
    -> ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
    -> IO TestSuiteLog
    doTest HPCMarkupInfo
    hpcMarkupInfo ((TestSuite
    suite, ComponentLocalBuildInfo
    clbi), Maybe TestSuiteLog
    _) =
            case TestSuite -> TestSuiteInterface
    PD.testInterface TestSuite
    suite of
              PD.TestSuiteExeV10 Version
    _ FilePath
    _ ->
                PackageDescription
    -> LocalBuildInfo
    -> ComponentLocalBuildInfo
    -> HPCMarkupInfo
    -> TestFlags
    -> TestSuite
    -> IO TestSuiteLog
    ExeV10.runTest PackageDescription
    pkg_descr LocalBuildInfo
    lbi ComponentLocalBuildInfo
    clbi HPCMarkupInfo
    hpcMarkupInfo TestFlags
    flags TestSuite
    suite
              PD.TestSuiteLibV09 Version
    _ ModuleName
    _ ->
                PackageDescription
    -> LocalBuildInfo
    -> ComponentLocalBuildInfo
    -> HPCMarkupInfo
    -> TestFlags
    -> TestSuite
    -> IO TestSuiteLog
    LibV09.runTest PackageDescription
    pkg_descr LocalBuildInfo
    lbi ComponentLocalBuildInfo
    clbi HPCMarkupInfo
    hpcMarkupInfo TestFlags
    flags TestSuite
    suite
              TestSuiteInterface
    _ ->
                TestSuiteLog -> IO TestSuiteLog
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
                  TestSuiteLog
                    { testSuiteName :: UnqualComponentName
    testSuiteName = TestSuite -> UnqualComponentName
    PD.testName TestSuite
    suite
                    , testLogs :: TestLogs
    testLogs =
                        TestLog
                          { testName :: FilePath
    testName = UnqualComponentName -> FilePath
    unUnqualComponentName (UnqualComponentName -> FilePath)
    -> UnqualComponentName -> FilePath
    forall a b. (a -> b) -> a -> b
    $ TestSuite -> UnqualComponentName
    PD.testName TestSuite
    suite
                          , testOptionsReturned :: Options
    testOptionsReturned = []
                          , testResult :: Result
    testResult =
                              FilePath -> Result
    Error (FilePath -> Result) -> FilePath -> Result
    forall a b. (a -> b) -> a -> b
    $
                                FilePath
    "No support for running test suite type: "
                                  FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ Doc -> FilePath
    forall a. Show a => a -> FilePath
    show (TestType -> Doc
    forall a. Pretty a => a -> Doc
    pretty (TestType -> Doc) -> TestType -> Doc
    forall a b. (a -> b) -> a -> b
    $ TestSuite -> TestType
    PD.testType TestSuite
    suite)
                          }
                    , logFile :: FilePath
    logFile = FilePath
    ""
                    }

      Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (PackageDescription -> Bool
    PD.hasTests PackageDescription
    pkg_descr) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
        Verbosity -> FilePath -> IO ()
    notice Verbosity
    verbosity FilePath
    "Package has no test suites."
        IO ()
    forall a. IO a
    exitSuccess

      Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (PackageDescription -> Bool
    PD.hasTests PackageDescription
    pkg_descr Bool -> Bool -> Bool
    && [(TestSuite, ComponentLocalBuildInfo)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(TestSuite, ComponentLocalBuildInfo)]
    enabledTests) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
        Verbosity -> CabalException -> IO ()
    forall a1 a.
    (HasCallStack, Show a1, Typeable a1,
     Exception (VerboseException a1)) =>
    Verbosity -> a1 -> IO a
    dieWithException Verbosity
    verbosity CabalException
    NoTestSuitesEnabled

      testsToRun <- case Args
    testNames of
        [] -> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
    -> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
     -> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)])
    -> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
    -> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
    forall a b. (a -> b) -> a -> b
    $ [(TestSuite, ComponentLocalBuildInfo)]
    -> [Maybe TestSuiteLog]
    -> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [(TestSuite, ComponentLocalBuildInfo)]
    enabledTests ([Maybe TestSuiteLog]
     -> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)])
    -> [Maybe TestSuiteLog]
    -> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
    forall a b. (a -> b) -> a -> b
    $ Maybe TestSuiteLog -> [Maybe TestSuiteLog]
    forall a. a -> [a]
    repeat Maybe TestSuiteLog
    forall a. Maybe a
    Nothing
        Args
    names -> Args
    -> (FilePath
        -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
    -> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    t a -> (a -> f b) -> f (t b)
    for Args
    names ((FilePath
      -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
     -> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)])
    -> (FilePath
        -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
    -> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
    forall a b. (a -> b) -> a -> b
    $ \FilePath
    tName ->
          let testMap :: [(UnqualComponentName, (TestSuite, ComponentLocalBuildInfo))]
    testMap = [UnqualComponentName]
    -> [(TestSuite, ComponentLocalBuildInfo)]
    -> [(UnqualComponentName, (TestSuite, ComponentLocalBuildInfo))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [UnqualComponentName]
    enabledNames [(TestSuite, ComponentLocalBuildInfo)]
    enabledTests
              enabledNames :: [UnqualComponentName]
    enabledNames = ((TestSuite, ComponentLocalBuildInfo) -> UnqualComponentName)
    -> [(TestSuite, ComponentLocalBuildInfo)] -> [UnqualComponentName]
    forall a b. (a -> b) -> [a] -> [b]
    map (TestSuite -> UnqualComponentName
    PD.testName (TestSuite -> UnqualComponentName)
    -> ((TestSuite, ComponentLocalBuildInfo) -> TestSuite)
    -> (TestSuite, ComponentLocalBuildInfo)
    -> UnqualComponentName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (TestSuite, ComponentLocalBuildInfo) -> TestSuite
    forall a b. (a, b) -> a
    fst) [(TestSuite, ComponentLocalBuildInfo)]
    enabledTests
              allNames :: [UnqualComponentName]
    allNames = (TestSuite -> UnqualComponentName)
    -> [TestSuite] -> [UnqualComponentName]
    forall a b. (a -> b) -> [a] -> [b]
    map TestSuite -> UnqualComponentName
    PD.testName [TestSuite]
    pkgTests
              tCompName :: UnqualComponentName
    tCompName = FilePath -> UnqualComponentName
    mkUnqualComponentName FilePath
    tName
           in case UnqualComponentName
    -> [(UnqualComponentName, (TestSuite, ComponentLocalBuildInfo))]
    -> Maybe (TestSuite, ComponentLocalBuildInfo)
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup UnqualComponentName
    tCompName [(UnqualComponentName, (TestSuite, ComponentLocalBuildInfo))]
    testMap of
                Just (TestSuite, ComponentLocalBuildInfo)
    t -> ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
    -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((TestSuite, ComponentLocalBuildInfo)
    t, Maybe TestSuiteLog
    forall a. Maybe a
    Nothing)
                Maybe (TestSuite, ComponentLocalBuildInfo)
    _
                  | UnqualComponentName
    tCompName UnqualComponentName -> [UnqualComponentName] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [UnqualComponentName]
    allNames ->
                      Verbosity
    -> CabalException
    -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
    forall a1 a.
    (HasCallStack, Show a1, Typeable a1,
     Exception (VerboseException a1)) =>
    Verbosity -> a1 -> IO a
    dieWithException Verbosity
    verbosity (CabalException
     -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
    -> CabalException
    -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> CabalException
    TestNameDisabled FilePath
    tName
                  | Bool
    otherwise -> Verbosity
    -> CabalException
    -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
    forall a1 a.
    (HasCallStack, Show a1, Typeable a1,
     Exception (VerboseException a1)) =>
    Verbosity -> a1 -> IO a
    dieWithException Verbosity
    verbosity (CabalException
     -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
    -> CabalException
    -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> CabalException
    NoSuchTest FilePath
    tName

      createDirectoryIfMissing True testLogDir

      -- Delete ordinary files from test log directory.
      getDirectoryContents testLogDir
        >>= filterM doesFileExist . map (testLogDir </>)
        >>= traverse_ removeFile

      -- We configured the unit-ids of libraries we should cover in our coverage
      -- report at configure time into the local build info. At build time, we built
      -- the hpc artifacts into the extraCompilationArtifacts directory, which, at
      -- install time, is copied into the ghc-pkg database files.
      -- Now, we get the path to the HPC artifacts and exposed modules of each
      -- library by querying the package database keyed by unit-id:
      let coverageFor =
            [UnitId] -> [UnitId]
    forall a. Eq a => [a] -> [a]
    nub ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
    forall a b. (a -> b) -> a -> b
    $
              [UnitId] -> Flag [UnitId] -> [UnitId]
    forall a. a -> Flag a -> a
    fromFlagOrDefault [] (ConfigFlags -> Flag [UnitId]
    configCoverageFor (LocalBuildInfo -> ConfigFlags
    configFlags LocalBuildInfo
    lbi))
                [UnitId] -> [UnitId] -> [UnitId]
    forall a. Semigroup a => a -> a -> a
    <> LocalBuildInfo -> [UnitId]
    extraCoverageFor LocalBuildInfo
    lbi
      ipkginfos <- getInstalledPackagesById verbosity lbi MissingCoveredInstalledLibrary coverageFor
      let ( concat -> pathsToLibsArtifacts
            , concat -> libsModulesToInclude
            ) =
              unzip $
                map
                  ( \InstalledPackageInfo
    ip ->
                      ( (FilePath -> FilePath) -> Args -> Args
    forall a b. (a -> b) -> [a] -> [b]
    map (FilePath -> FilePath -> FilePath
    </> FilePath
    extraCompilationArtifacts) (Args -> Args) -> Args -> Args
    forall a b. (a -> b) -> a -> b
    $ InstalledPackageInfo -> Args
    libraryDirs InstalledPackageInfo
    ip
                      , (ExposedModule -> ModuleName) -> [ExposedModule] -> [ModuleName]
    forall a b. (a -> b) -> [a] -> [b]
    map ExposedModule -> ModuleName
    exposedName ([ExposedModule] -> [ModuleName])
    -> [ExposedModule] -> [ModuleName]
    forall a b. (a -> b) -> a -> b
    $ InstalledPackageInfo -> [ExposedModule]
    exposedModules InstalledPackageInfo
    ip
                      )
                  )
                  ipkginfos
          hpcMarkupInfo = HPCMarkupInfo{Args
    pathsToLibsArtifacts :: Args
    pathsToLibsArtifacts :: Args
    pathsToLibsArtifacts, [ModuleName]
    libsModulesToInclude :: [ModuleName]
    libsModulesToInclude :: [ModuleName]
    libsModulesToInclude}

      let totalSuites = [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
    testsToRun
      notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."
      suites <- traverse (doTest hpcMarkupInfo) testsToRun
      let packageLog = (PackageDescription -> LocalBuildInfo -> PackageLog
    localPackageLog PackageDescription
    pkg_descr LocalBuildInfo
    lbi){testSuites = suites}
          packageLogFile =
            FilePath -> FilePath -> FilePath
    (</>) FilePath
    testLogDir (FilePath -> FilePath) -> FilePath -> FilePath
    forall a b. (a -> b) -> a -> b
    $
              PathTemplate -> PackageDescription -> LocalBuildInfo -> FilePath
    packageLogPath PathTemplate
    machineTemplate PackageDescription
    pkg_descr LocalBuildInfo
    lbi
      allOk <- summarizePackage verbosity packageLog
      writeFile packageLogFile $ show packageLog

      when (LBI.testCoverage lbi) $
        markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr $
          map (fst . fst) testsToRun

      unless allOk exitFailure

    packageLogPath
      :: PathTemplate
      -> PD.PackageDescription
      -> LBI.LocalBuildInfo
      -> FilePath
    packageLogPath :: PathTemplate -> PackageDescription -> LocalBuildInfo -> FilePath
    packageLogPath PathTemplate
    template PackageDescription
    pkg_descr LocalBuildInfo
    lbi =
      PathTemplate -> FilePath
    fromPathTemplate (PathTemplate -> FilePath) -> PathTemplate -> FilePath
    forall a b. (a -> b) -> a -> b
    $ PathTemplateEnv -> PathTemplate -> PathTemplate
    substPathTemplate PathTemplateEnv
    env PathTemplate
    template
      where
        env :: PathTemplateEnv
    env =
          PackageIdentifier
    -> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
    initialPathTemplateEnv
            (PackageDescription -> PackageIdentifier
    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)