Commit 6a0d4518 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Test suite: create symlinks as needed.

Fixes #3190.
parent 70cc6971
......@@ -414,7 +414,7 @@ test-suite package-tests
regex-posix,
old-time
if !os(windows)
build-depends: unix
build-depends: unix, exceptions
ghc-options: -Wall -rtsopts
default-extensions: CPP
default-language: Haskell98
......@@ -57,6 +57,7 @@ module PackageTests.PackageTester
, assertFindInFile
, concatOutput
, ghcFileModDelay
, withSymlink
-- * Test trees
, TestTreeM
......@@ -126,6 +127,12 @@ import System.Process (runProcess, waitForProcess, showCommandForUser)
import Control.Concurrent (threadDelay)
import Test.Tasty (TestTree, askOption, testGroup)
#ifndef mingw32_HOST_OS
import Control.Monad.Catch ( bracket_ )
import System.Directory ( removeFile )
import System.Posix.Files ( createSymbolicLink )
#endif
-- | Our test monad maintains an environment recording the global test
-- suite configuration 'SuiteConfig', and the local per-test
-- configuration 'TestConfig'.
......@@ -741,6 +748,20 @@ ghcFileModDelay = do
= mtimeChangeDelay suite
liftIO $ threadDelay delay
-- | Create a symlink for the duration of the provided action. If the symlink
-- already exists, it is deleted. Does not work on Windows.
withSymlink :: FilePath -> FilePath -> TestM a -> TestM a
#ifdef mingw32_HOST_OS
withSymlink _oldpath _newpath _act =
error "PackageTests.PackageTester.withSymlink: does not work on Windows!"
#else
withSymlink oldpath newpath act = do
symlinkExists <- liftIO $ doesFileExist newpath
when symlinkExists $ liftIO $ removeFile newpath
bracket_ (liftIO $ createSymbolicLink oldpath newpath)
(liftIO $ removeFile newpath) act
#endif
------------------------------------------------------------------------
-- * Test trees
......
......@@ -270,9 +270,21 @@ tests config = do
tc "GhcPkgGuess/SameDirectoryGhcVersion" $ ghc_pkg_guess "ghc-7.10"
unlessWindows $ do
tc "GhcPkgGuess/Symlink" $ ghc_pkg_guess "ghc"
tc "GhcPkgGuess/SymlinkVersion" $ ghc_pkg_guess "ghc"
tc "GhcPkgGuess/SymlinkGhcVersion" $ ghc_pkg_guess "ghc"
tc "GhcPkgGuess/Symlink" $ do
-- We don't want to distribute a tarball with symlinks. See #3190.
withSymlink "bin/ghc"
"tests/PackageTests/GhcPkgGuess/Symlink/ghc" $
ghc_pkg_guess "ghc"
tc "GhcPkgGuess/SymlinkVersion" $ do
withSymlink "bin/ghc-7.10"
"tests/PackageTests/GhcPkgGuess/SymlinkVersion/ghc" $
ghc_pkg_guess "ghc"
tc "GhcPkgGuess/SymlinkGhcVersion" $ do
withSymlink "bin/ghc-7.10"
"tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/ghc" $
ghc_pkg_guess "ghc"
-- Basic test for internal libraries (in p); package q is to make
-- sure that the internal library correctly is used, not the
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment