[commit: ghc] wip/nfs-locking: Fix install rules by untracking copy files and use relative path (#396) (942ed27)

git at git.haskell.org git at git.haskell.org
Fri Oct 27 01:24:59 UTC 2017


Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/942ed27a622576252ef7178040f0b1fdbf08ca1c/ghc

>---------------------------------------------------------------

commit 942ed27a622576252ef7178040f0b1fdbf08ca1c
Author: Zhen Zhang <izgzhen at gmail.com>
Date:   Sat Aug 19 09:39:25 2017 +0800

    Fix install rules by untracking copy files and use relative path (#396)


>---------------------------------------------------------------

942ed27a622576252ef7178040f0b1fdbf08ca1c
 src/Hadrian/Oracles/DirectoryContents.hs | 10 +++++++++-
 src/Rules/Install.hs                     |  8 +++++---
 2 files changed, 14 insertions(+), 4 deletions(-)

diff --git a/src/Hadrian/Oracles/DirectoryContents.hs b/src/Hadrian/Oracles/DirectoryContents.hs
index 19a5192..f302af9 100644
--- a/src/Hadrian/Oracles/DirectoryContents.hs
+++ b/src/Hadrian/Oracles/DirectoryContents.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
 module Hadrian.Oracles.DirectoryContents (
-    directoryContents, copyDirectoryContents, directoryContentsOracle,
+    directoryContents, copyDirectoryContents, directoryContentsOracle, copyDirectoryContentsUntracked,
     Match (..), matches, matchAll
     ) where
 
@@ -45,6 +45,14 @@ copyDirectoryContents expr source target = do
     let cp file = copyFile file $ target -/- makeRelative source file
     mapM_ cp =<< directoryContents expr source
 
+-- | Copy the contents of the source directory that matches a given 'Match'
+-- expression into the target directory. The copied contents is untracked.
+copyDirectoryContentsUntracked :: Match -> FilePath -> FilePath -> Action ()
+copyDirectoryContentsUntracked expr source target = do
+    putProgressInfo =<< renderAction "Copy directory contents (untracked)" source target
+    let cp file = copyFileUntracked file $ target -/- makeRelative source file
+    mapM_ cp =<< directoryContents expr source
+
 newtype DirectoryContents = DirectoryContents (Match, FilePath)
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
 type instance RuleResult DirectoryContents = [FilePath]
diff --git a/src/Rules/Install.hs b/src/Rules/Install.hs
index 12135b4..2400933 100644
--- a/src/Rules/Install.hs
+++ b/src/Rules/Install.hs
@@ -186,7 +186,9 @@ installPackages = do
             withLatestBuildStage pkg $ \stage -> do
                 let context = vanillaContext stage pkg
                 top <- topDirectory
-                installDistDir <- (top -/-) <$> buildPath context
+                installDistDir <- buildPath context
+                let absInstallDistDir = top -/- installDistDir
+
                 need =<< packageTargets stage pkg
                 docDir <- installDocDir
                 ghclibDir <- installGhcLibDir
@@ -203,7 +205,7 @@ installPackages = do
                 need [cabalFile, pkgConf] -- TODO: check if need pkgConf
 
                 -- HACK (#318): copy stuff back to the place favored by ghc-cabal
-                quietly $ copyDirectoryContents (Not excluded)
+                quietly $ copyDirectoryContentsUntracked (Not excluded)
                     installDistDir (installDistDir -/- "build")
 
                 whenM (isSpecified HsColour) $
@@ -212,7 +214,7 @@ installPackages = do
                 pref <- setting InstallPrefix
                 unit $ cmd ghcCabalInplace [ "copy"
                                            , pkgPath pkg
-                                           , installDistDir
+                                           , absInstallDistDir
                                            , strip
                                            , destDir
                                            , pref



More information about the ghc-commits mailing list