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.

6 files changed, 29 insertions, 10 deletions

diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal
index 56c68aa0c3..a5a1ead0e7 100644
--- a/hadrian/hadrian.cabal
+++ b/hadrian/hadrian.cabal
@@ -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
diff --git a/hadrian/src/Hadrian/Builder/Tar.hs b/hadrian/src/Hadrian/Builder/Tar.hs
index 75cf725b4b..1d8f5025a5 100644
--- a/hadrian/src/Hadrian/Builder/Tar.hs
+++ b/hadrian/src/Hadrian/Builder/Tar.hs
@@ -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"
diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs
index 3e5d7b37db..e5fc712512 100644
--- a/hadrian/src/Hadrian/Utilities.hs
+++ b/hadrian/src/Hadrian/Utilities.hs
@@ -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
diff --git a/hadrian/src/Rules/Gmp.hs b/hadrian/src/Rules/Gmp.hs
index a78170cf6a..e4f7e53b48 100644
--- a/hadrian/src/Rules/Gmp.hs
+++ b/hadrian/src/Rules/Gmp.hs
@@ -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
diff --git a/hadrian/src/Rules/Libffi.hs b/hadrian/src/Rules/Libffi.hs
index 64f63039eb..5b25aab5ba 100644
--- a/hadrian/src/Rules/Libffi.hs
+++ b/hadrian/src/Rules/Libffi.hs
@@ -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 <//> "*"]
diff --git a/hadrian/src/Rules/Selftest.hs b/hadrian/src/Rules/Selftest.hs
index 68aa6e3889..b931f85ef6 100644
--- a/hadrian/src/Rules/Selftest.hs
+++ b/hadrian/src/Rules/Selftest.hs
@@ -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