Commit 2ff77b98 authored by P.C. Shyamshankar's avatar P.C. Shyamshankar Committed by Marge Bot

Handle absolute paths to build roots in Hadrian.

Fixes #16187.

This patch fixes various path concatenation issues to allow functioning
builds with hadrian when the build root location is specified with an
absolute path.

Remarks:

- The path concatenation operator (-/-) now handles absolute second operands
  appropriately. Its behavior should match that of POSIX (</>) in this
  regard.

- The `getDirectoryFiles*` family of functions only searches for matches
  under the directory tree rooted by its first argument; all of the
  results are also relative to this root. If the first argument is the
  empty string, the current working directory is used.

  This patch passes the appropriate directory (almost always either `top`
  or `root`), and subsequently attaches that directory prefix so that
  the paths refer to the appropriate files.

- Windows `tar` does not like colons (':') in paths to archive files, it
  tries to resolve them as remote paths. The `--force-local` option
  remedies this, and is applied on windows builds.
parent db039a4a
Pipeline #3165 passed with stages
in 415 minutes and 34 seconds
......@@ -121,6 +121,7 @@ executable hadrian
, containers >= 0.5 && < 0.7
, directory >= 1.2 && < 1.4
, extra >= 1.4.7
, filepath
, mtl == 2.2.*
, parsec >= 3.1 && < 3.2
, QuickCheck >= 2.6 && < 2.13
......
......@@ -14,6 +14,7 @@ import Development.Shake
import Development.Shake.Classes
import GHC.Generics
import Hadrian.Expression
import Oracles.Setting
-- | Tar can be used to 'Create' an archive or 'Extract' from it.
data TarMode = Create | Extract deriving (Eq, Generic, Show)
......@@ -34,6 +35,7 @@ args Create = mconcat
, getInputs ]
args Extract = mconcat
[ arg "-x"
, windowsHost ? arg "--force-local"
, input "*.gz" ? arg "--gzip"
, input "*.bz2" ? arg "--bzip2"
, input "*.xz" ? arg "--xz"
......
......@@ -133,6 +133,7 @@ unifyPath = toStandard . normaliseEx
-- | Combine paths with a forward slash regardless of platform.
(-/-) :: FilePath -> FilePath -> FilePath
_ -/- b | isAbsolute b && not (isAbsolute $ tail b) = b
"" -/- b = b
a -/- b
| last a == '/' = a ++ b
......
......@@ -15,8 +15,8 @@ gmpObjects = do
-- The line below causes a Shake Lint failure on Windows, which forced us to
-- disable Lint by default. See more details here:
-- https://ghc.haskell.org/trac/ghc/ticket/15971.
map unifyPath <$>
liftIO (getDirectoryFilesIO "" [gmpPath -/- gmpObjectsDir -/- "*.o"])
map (unifyPath . (gmpPath -/-)) <$>
liftIO (getDirectoryFilesIO gmpPath [gmpObjectsDir -/- "*.o"])
gmpBase :: FilePath
gmpBase = pkgPath integerGmp -/- "gmp"
......@@ -103,18 +103,19 @@ gmpRules = do
-- Extract in-tree GMP sources and apply patches
fmap (gmpPath -/-) ["Makefile.in", "configure"] &%> \_ -> do
top <- topDirectory
removeDirectory gmpPath
-- Note: We use a tarball like gmp-4.2.4-nodoc.tar.bz2, which is
-- gmp-4.2.4.tar.bz2 repacked without the doc/ directory contents.
-- That's because the doc/ directory contents are under the GFDL,
-- which causes problems for Debian.
tarball <- unifyPath . fromSingleton "Exactly one GMP tarball is expected"
<$> getDirectoryFiles "" [gmpBase -/- "gmp-tarballs/gmp*.tar.bz2"]
<$> getDirectoryFiles top [gmpBase -/- "gmp-tarballs/gmp*.tar.bz2"]
withTempDir $ \dir -> do
let tmp = unifyPath dir
need [tarball]
build $ target gmpContext (Tar Extract) [tarball] [tmp]
need [top -/- tarball]
build $ target gmpContext (Tar Extract) [top -/- tarball] [tmp]
let patch = gmpBase -/- "gmpsrc.patch"
patchName = takeFileName patch
......
......@@ -114,10 +114,10 @@ libffiRules = forM_ [Stage1 ..] $ \stage -> do
build $ target context (Make libffiPath) [] []
-- Here we produce 'libffiDependencies'
headers <- liftIO $ getDirectoryFilesIO "" [libffiPath -/- "inst/include/*"]
headers <- liftIO $ getDirectoryFilesIO libffiPath ["inst/include/*"]
forM_ headers $ \header -> do
let target = rtsPath -/- takeFileName header
copyFileUntracked header target
copyFileUntracked (libffiPath -/- header) target
produces [target]
-- Find ways.
......@@ -171,10 +171,11 @@ libffiRules = forM_ [Stage1 ..] $ \stage -> do
-- Extract libffi tar file
context <- libffiContext stage
removeDirectory libffiPath
top <- topDirectory
tarball <- unifyPath . fromSingleton "Exactly one LibFFI tarball is expected"
<$> getDirectoryFiles "" ["libffi-tarballs/libffi*.tar.gz"]
<$> getDirectoryFiles top ["libffi-tarballs/libffi*.tar.gz"]
need [tarball]
need [top -/- tarball]
-- Go from 'libffi-3.99999+git20171002+77e130c.tar.gz' to 'libffi-3.99999'
let libname = takeWhile (/= '+') $ takeFileName tarball
......@@ -187,7 +188,6 @@ libffiRules = forM_ [Stage1 ..] $ \stage -> do
-- And finally:
removeFiles (path) [libname <//> "*"]
top <- topDirectory
fixFile mkIn (fixLibffiMakefile top)
files <- liftIO $ getDirectoryFilesIO "." [libffiPath <//> "*"]
......
......@@ -13,6 +13,8 @@ import Settings
import Target
import Utilities
import qualified System.FilePath.Posix as Posix ((</>))
instance Arbitrary Way where
arbitrary = wayFromUnits <$> arbitrary
......@@ -31,6 +33,7 @@ selftestRules =
testLookupAll
testModuleName
testPackages
testPaths
testWay
testBuilder :: Action ()
......@@ -111,3 +114,14 @@ testWay :: Action ()
testWay = do
putBuild "==== Read Way, Show Way"
test $ \(x :: Way) -> read (show x) == x
testPaths :: Action ()
testPaths = do
putBuild "==== Absolute, Relative Path Concatenation"
test $ forAll paths $ \(path1, path2) ->
path1 -/- path2 == path1 Posix.</> path2
where
paths = (,) <$> path <*> path
path = frequency [(1, relativePath), (1, absolutePath)]
relativePath = intercalate "/" <$> listOf1 (elements ["a"])
absolutePath = ('/':) <$> relativePath
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