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.

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

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"

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

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

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 <//> "*"]

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