3802b46 · stackage · git.iko.soy

6 ) where

7

8import qualified Control.Concurrent as C

9−import Control.Exception (Exception, SomeException, handle, throwIO, IOException)

9+import Control.Exception (Exception, SomeException, handle, throwIO, IOException, try)

10import Control.Monad (replicateM, unless, when, forM_)

11import qualified Data.Map as Map

12import qualified Data.Set as Set

17import System.Directory (copyFile, createDirectory,

18 createDirectoryIfMissing, doesFileExist, findExecutable,

19 getDirectoryContents, removeFile,

20− renameDirectory)

20+ renameDirectory, canonicalizePath)

21import System.Exit (ExitCode (ExitSuccess))

22import System.FilePath ((<.>), (</>), takeDirectory)

23import System.IO (IOMode (WriteMode, AppendMode),

24 withBinaryFile)

25import System.Process (readProcess, runProcess, waitForProcess)

26import Text.ParserCombinators.ReadP (readP_to_S)

27+import Data.IORef (IORef, readIORef, atomicModifyIORef, newIORef)

27

28

28runTestSuites :: BuildSettings -> BuildPlan -> IO ()

29runTestSuites :: BuildSettings -> BuildPlan -> IO ()

29runTestSuites settings' bp = do

30runTestSuites settings' bp = do

40 copyBuiltInHaddocks docdir

41 copyBuiltInHaddocks docdir

41

42

42 cabalVersion <- getCabalVersion

43 cabalVersion <- getCabalVersion

44+ haddockFilesRef <- newIORef []

43− allPass <- parFoldM (testWorkerThreads settings) (runTestSuite cabalVersion settings testdir docdir bp) (&&) True $ Map.toList selected

45+ allPass <- parFoldM (testWorkerThreads settings) (runTestSuite cabalVersion settings testdir docdir bp haddockFilesRef) (&&) True $ Map.toList selected

44 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir

46 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir

45 where

47 where

46 notSkipped p _ = p `Set.notMember` bpSkippedTests bp

48 notSkipped p _ = p `Set.notMember` bpSkippedTests bp

108 -> FilePath -- ^ testdir

110 -> FilePath -- ^ testdir

109 -> FilePath -- ^ docdir

111 -> FilePath -- ^ docdir

110 -> BuildPlan

112 -> BuildPlan

113+ -> IORef [FilePath] -- ^ .haddock files

111 -> (PackageName, SelectedPackageInfo)

114 -> (PackageName, SelectedPackageInfo)

112 -> IO Bool

115 -> IO Bool

113−runTestSuite cabalVersion settings testdir docdir bp (packageName, SelectedPackageInfo {..}) = do

116+runTestSuite cabalVersion settings testdir docdir

117+ bp haddockFilesRef (packageName, SelectedPackageInfo {..}) = do

114 -- Set up a new environment that includes the sandboxed bin folder in PATH.

118 -- Set up a new environment that includes the sandboxed bin folder in PATH.

115 env' <- getModifiedEnv settings

119 env' <- getModifiedEnv settings

116 let menv = Just $ addSandbox env'

120 let menv = Just $ addSandbox env'

137

141

138 -- Try building docs first in case tests have an expected failure.

142 -- Try building docs first in case tests have an expected failure.

139 when (buildDocs settings) $ do

143 when (buildDocs settings) $ do

144+ hfs <- readIORef haddockFilesRef

145+ let hfsOpts = map ("--haddock-options=-o " ++) hfs

140 getHandle AppendMode $ run "cabal"

146 getHandle AppendMode $ run "cabal"

141− [ "haddock"

147+ ( "haddock"

142− , "--hyperlink-source"

148+ : "--hyperlink-source"

143− , "--html"

149+ : "--html"

144− , "--hoogle"

150+ : "--hoogle"

145− , "--html-location=../$pkg-$version/"

151+ : "--html-location=../$pkg-$version/"

146− ] dir

152+ : hfsOpts) dir

147 let PackageName packageName' = packageName

153 let PackageName packageName' = packageName

148 handle (\(_ :: IOException) -> return ()) $ renameDirectory

154 handle (\(_ :: IOException) -> return ()) $ renameDirectory

149 (dir </> "dist" </> "doc" </> "html" </> packageName')

155 (dir </> "dist" </> "doc" </> "html" </> packageName')

150 (docdir </> package)

156 (docdir </> package)

151

157

158+ enewPath <- try $ canonicalizePath $ docdir </> package </> packageName' <.> "haddock"

159+ case enewPath :: Either IOException FilePath of

160+ Left e -> print e

161+ Right newPath -> atomicModifyIORef haddockFilesRef $ \hfs'

162+ -> (newPath : hfs', ())

163+

152 when spiHasTests $ do

164 when spiHasTests $ do

153 getHandle AppendMode $ run "cabal" ["build"] dir

165 getHandle AppendMode $ run "cabal" ["build"] dir

154 getHandle AppendMode $ run "cabal" (concat

166 getHandle AppendMode $ run "cabal" (concat