[commit: ghc] wip/nfs-locking: Add missing src/Oracles/Path.hs (e1e2621)

[git at git.haskell.org]

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

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

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

commit e1e2621d6bdd5ebe98fb3787733d134fa4d2fd70
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Sun Oct 30 01:01:43 2016 +0000

    Add missing src/Oracles/Path.hs


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

e1e2621d6bdd5ebe98fb3787733d134fa4d2fd70
 src/Oracles/Path.hs | 83 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 83 insertions(+)

diff --git a/src/Oracles/Path.hs b/src/Oracles/Path.hs
new file mode 100644
index 0000000..7db1400
--- /dev/null
+++ b/src/Oracles/Path.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Oracles.Path (
+    fixAbsolutePathOnWindows, topDirectory, getTopDirectory, windowsPathOracle,
+    systemBuilderPath
+    ) where
+
+import Control.Monad.Trans.Reader
+import Data.Char
+
+import Base
+import Builder
+import Oracles.Config
+import Oracles.Config.Setting
+import Oracles.LookupInPath
+import Stage
+
+newtype WindowsPath = WindowsPath FilePath
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+
+-- | Path to the GHC source tree.
+topDirectory :: Action FilePath
+topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
+
+getTopDirectory :: ReaderT a Action FilePath
+getTopDirectory = lift topDirectory
+
+-- | Determine the location of a system 'Builder'.
+systemBuilderPath :: Builder -> Action FilePath
+systemBuilderPath builder = case builder of
+    Alex          -> fromKey "alex"
+    Ar            -> fromKey "ar"
+    Cc  _  Stage0 -> fromKey "system-cc"
+    Cc  _  _      -> fromKey "cc"
+    -- We can't ask configure for the path to configure!
+    Configure _   -> return "bash configure"
+    Ghc _  Stage0 -> fromKey "system-ghc"
+    GhcPkg Stage0 -> fromKey "system-ghc-pkg"
+    Happy         -> fromKey "happy"
+    HsColour      -> fromKey "hscolour"
+    HsCpp         -> fromKey "hs-cpp"
+    Ld            -> fromKey "ld"
+    Make _        -> fromKey "make"
+    Nm            -> fromKey "nm"
+    Objdump       -> fromKey "objdump"
+    Patch         -> fromKey "patch"
+    Perl          -> fromKey "perl"
+    Ranlib        -> fromKey "ranlib"
+    Tar           -> fromKey "tar"
+    _             -> error $ "No system.config entry for " ++ show builder
+  where
+    fromKey key = do
+        let unpack = fromMaybe . error $ "Cannot find path to builder "
+                ++ quote key ++ " in system.config file. Did you skip configure?"
+        path <- unpack <$> askConfig key
+        if null path
+        then do
+            unless (isOptional builder) . error $ "Non optional builder "
+                ++ quote key ++ " is not specified in system.config file."
+            return "" -- TODO: Use a safe interface.
+        else fixAbsolutePathOnWindows =<< lookupInPath path
+
+-- | Fix an absolute path on Windows:
+-- * "/c/" => "C:/"
+-- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
+fixAbsolutePathOnWindows :: FilePath -> Action FilePath
+fixAbsolutePathOnWindows path = do
+    windows <- windowsHost
+    if windows
+    then do
+        let (dir, file) = splitFileName path
+        winDir <- askOracle $ WindowsPath dir
+        return $ winDir -/- file
+    else
+        return path
+
+-- | Compute path mapping on Windows. This is slow and requires caching.
+windowsPathOracle :: Rules ()
+windowsPathOracle = void $
+    addOracle $ \(WindowsPath path) -> do
+        Stdout out <- quietly $ cmd ["cygpath", "-m", path]
+        let windowsPath = unifyPath $ dropWhileEnd isSpace out
+        putLoud $ "Windows path mapping: " ++ path ++ " => " ++ windowsPath
+        return windowsPath