Distribution/Simple/Test/LibV09.hs

    module Distribution.Simple.Test.LibV09
           ( runTest
             -- Test stub
           , simpleTestStub
           , stubFilePath, stubMain, stubName, stubWriteLog
           , writeSimpleTestStub
           ) where

    import Distribution.Compat.CreatePipe ( createPipe )
    import Distribution.Compat.Environment ( getEnvironment )
    import Distribution.Compat.TempFile ( openTempFile )
    import Distribution.ModuleName ( ModuleName )
    import qualified Distribution.PackageDescription as PD
    import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )
    import Distribution.Simple.BuildPaths ( exeExtension )
    import Distribution.Simple.Compiler ( compilerInfo )
    import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath )
    import Distribution.Simple.InstallDirs
        ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
        , substPathTemplate , toPathTemplate, PathTemplate )
    import qualified Distribution.Simple.LocalBuildInfo as LBI
    import Distribution.Simple.Setup
        ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage )
    import Distribution.Simple.Test.Log
    import Distribution.Simple.Utils
        ( die, notice, rawSystemIOWithEnv, addLibraryPath )
    import Distribution.System ( Platform (..) )
    import Distribution.TestSuite
    import Distribution.Text
    import Distribution.Verbosity ( normal )

    import Control.Exception ( bracket )
    import Control.Monad ( when, unless )
    import Data.Maybe ( mapMaybe )
    import System.Directory
        ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
        , getCurrentDirectory, removeDirectoryRecursive, removeFile
        , setCurrentDirectory )
    import System.Exit ( ExitCode(..), exitWith )
    import System.FilePath ( (</>), (<.>) )
    import System.IO ( hClose, hGetContents, hPutStr )

    runTest :: PD.PackageDescription
            -> LBI.LocalBuildInfo
            -> TestFlags
            -> PD.TestSuite
            -> IO TestSuiteLog
    runTest pkg_descr lbi flags suite = do
        let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi
            way = guessWay lbi

        pwd <- getCurrentDirectory
        existingEnv <- getEnvironment

        let cmd = LBI.buildDir lbi </> stubName suite
                      </> stubName suite <.> exeExtension
        -- Check that the test executable exists.
        exists <- doesFileExist cmd
        unless exists $ die $ "Error: Could not find test program \"" ++ cmd
                              ++ "\". Did you build the package first?"

        -- Remove old .tix files if appropriate.
        unless (fromFlag $ testKeepTix flags) $ do
            let tDir = tixDir distPref way $ PD.testName suite
            exists' <- doesDirectoryExist tDir
            when exists' $ removeDirectoryRecursive tDir

        -- Create directory for HPC files.
        createDirectoryIfMissing True $ tixDir distPref way $ PD.testName suite

        -- Write summary notices indicating start of test suite
        notice verbosity $ summarizeSuiteStart $ PD.testName suite

        suiteLog <- bracket openCabalTemp deleteIfExists $ \tempLog -> do

            (rIn, wIn) <- createPipe
            (rOut, wOut) <- createPipe

            -- Prepare standard input for test executable
            --appendFile tempInput $ show (tempInput, PD.testName suite)
            hPutStr wIn $ show (tempLog, PD.testName suite)
            hClose wIn

            -- Run test executable
            _ <- do let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
                        dataDirPath = pwd </> PD.dataDir pkg_descr
                        tixFile = pwd </> tixFilePath distPref way (PD.testName suite)
                        pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
                                   : existingEnv
                        shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]
                                 ++ pkgPathEnv
                    -- Add (DY)LD_LIBRARY_PATH if needed
                    shellEnv' <- if LBI.withDynExe lbi
                                    then do
                                      let (Platform _ os) = LBI.hostPlatform lbi
                                          clbi = LBI.getComponentLocalBuildInfo
                                                       lbi
                                                       (LBI.CTestName
                                                          (PD.testName suite))
                                      paths <- LBI.depLibraryPaths
                                                 True False lbi clbi
                                      return (addLibraryPath os paths shellEnv)
                                    else return shellEnv
                    rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')
                                       -- these handles are closed automatically
                                       (Just rIn) (Just wOut) (Just wOut)

            -- Generate final log file name
            let finalLogName l = testLogDir
                                 </> testSuiteLogPath
                                     (fromFlag $ testHumanLog flags) pkg_descr lbi
                                     (testSuiteName l) (testLogs l)
            -- Generate TestSuiteLog from executable exit code and a machine-
            -- readable test log
            suiteLog <- fmap ((\l -> l { logFile = finalLogName l }) . read)
                        $ readFile tempLog

            -- Write summary notice to log file indicating start of test suite
            appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite

            -- Append contents of temporary log file to the final human-
            -- readable log file
            logText <- hGetContents rOut
            appendFile (logFile suiteLog) logText

            -- Write end-of-suite summary notice to log file
            appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog

            -- Show the contents of the human-readable log file on the terminal
            -- if there is a failure and/or detailed output is requested
            let details = fromFlag $ testShowDetails flags
                whenPrinting = when $ (details > Never)
                    && (not (suitePassed $ testLogs suiteLog) || details == Always)
                    && verbosity >= normal
            whenPrinting $ putStr $ unlines $ lines logText

            return suiteLog

        -- Write summary notice to terminal indicating end of test suite
        notice verbosity $ summarizeSuiteFinish suiteLog

        when isCoverageEnabled $
            markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite

        return suiteLog
      where
        deleteIfExists file = do
            exists <- doesFileExist file
            when exists $ removeFile file

        testLogDir = distPref </> "test"
        openCabalTemp = do
            (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"
            hClose h >> return f

        distPref = fromFlag $ testDistPref flags
        verbosity = fromFlag $ testVerbosity flags

    -- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't
    -- necessarily a path.
    testOption :: PD.PackageDescription
               -> LBI.LocalBuildInfo
               -> PD.TestSuite
               -> PathTemplate
               -> String
    testOption pkg_descr lbi suite template =
        fromPathTemplate $ substPathTemplate env template
      where
        env = initialPathTemplateEnv
              (PD.package pkg_descr) (LBI.pkgKey lbi)
              (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
              [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]

    -- Test stub ----------

    -- | The name of the stub executable associated with a library 'TestSuite'.
    stubName :: PD.TestSuite -> FilePath
    stubName t = PD.testName t ++ "Stub"

    -- | The filename of the source file for the stub executable associated with a
    -- library 'TestSuite'.
    stubFilePath :: PD.TestSuite -> FilePath
    stubFilePath t = stubName t <.> "hs"

    -- | Write the source file for a library 'TestSuite' stub executable.
    writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub
                                        -- is being created
                        -> FilePath     -- ^ path to directory where stub source
                                        -- should be located
                        -> IO ()
    writeSimpleTestStub t dir = do
        createDirectoryIfMissing True dir
        let filename = dir </> stubFilePath t
            PD.TestSuiteLibV09 _ m = PD.testInterface t
        writeFile filename $ simpleTestStub m

    -- | Source code for library test suite stub executable
    simpleTestStub :: ModuleName -> String
    simpleTestStub m = unlines
        [ "module Main ( main ) where"
        , "import Distribution.Simple.Test.LibV09 ( stubMain )"
        , "import " ++ show (disp m) ++ " ( tests )"
        , "main :: IO ()"
        , "main = stubMain tests"
        ]

    -- | Main function for test stubs. Once, it was written directly into the stub,
    -- but minimizing the amount of code actually in the stub maximizes the number
    -- of detectable errors when Cabal is compiled.
    stubMain :: IO [Test] -> IO ()
    stubMain tests = do
        (f, n) <- fmap read getContents
        dir <- getCurrentDirectory
        results <- tests >>= stubRunTests
        setCurrentDirectory dir
        stubWriteLog f n results

    -- | The test runner used in library "TestSuite" stub executables.  Runs a list
    -- of 'Test's.  An executable calling this function is meant to be invoked as
    -- the child of a Cabal process during @.\/setup test@.  A 'TestSuiteLog',
    -- provided by Cabal, is read from the standard input; it supplies the name of
    -- the test suite and the location of the machine-readable test suite log file.
    -- Human-readable log information is written to the standard output for capture
    -- by the calling Cabal process.
    stubRunTests :: [Test] -> IO TestLogs
    stubRunTests tests = do
        logs <- mapM stubRunTests' tests
        return $ GroupLogs "Default" logs
      where
        stubRunTests' (Test t) = do
            l <- run t >>= finish
            summarizeTest normal Always l
            return l
          where
            finish (Finished result) =
                return TestLog
                    { testName = name t
                    , testOptionsReturned = defaultOptions t
                    , testResult = result
                    }
            finish (Progress _ next) = next >>= finish
        stubRunTests' g@(Group {}) = do
            logs <- mapM stubRunTests' $ groupTests g
            return $ GroupLogs (groupName g) logs
        stubRunTests' (ExtraOptions _ t) = stubRunTests' t
        maybeDefaultOption opt =
            maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt
        defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst

    -- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling
    -- Cabal process to read.
    stubWriteLog :: FilePath -> String -> TestLogs -> IO ()
    stubWriteLog f n logs = do
        let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f }
        writeFile (logFile testLog) $ show testLog
        when (suiteError logs) $ exitWith $ ExitFailure 2
        when (suiteFailed logs) $ exitWith $ ExitFailure 1
        exitWith ExitSuccess