[commit: ghc] wip/nfs-locking: Implement path lookup on Windows. (f5299c8)

[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/f5299c86b5e89909488e1a5997a8c98c595f5d25/ghc

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

commit f5299c86b5e89909488e1a5997a8c98c595f5d25
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Tue Feb 9 15:05:09 2016 +0000

    Implement path lookup on Windows.


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

f5299c86b5e89909488e1a5997a8c98c595f5d25
 shaking-up-ghc.cabal       |  2 +-
 src/Oracles.hs             |  4 ++--
 src/Oracles/WindowsPath.hs | 41 +++++++++++++++++++++++++++++++++++++
 src/Oracles/WindowsRoot.hs | 51 ----------------------------------------------
 src/Rules/Oracles.hs       |  2 +-
 src/Test.hs                |  2 +-
 6 files changed, 46 insertions(+), 56 deletions(-)

diff --git a/shaking-up-ghc.cabal b/shaking-up-ghc.cabal
index 254617d..035bb9d 100644
--- a/shaking-up-ghc.cabal
+++ b/shaking-up-ghc.cabal
@@ -34,7 +34,7 @@ executable ghc-shake
                        , Oracles.PackageData
                        , Oracles.PackageDb
                        , Oracles.PackageDeps
-                       , Oracles.WindowsRoot
+                       , Oracles.WindowsPath
                        , Package
                        , Predicates
                        , Rules
diff --git a/src/Oracles.hs b/src/Oracles.hs
index 564c7bb..eb37b47 100644
--- a/src/Oracles.hs
+++ b/src/Oracles.hs
@@ -6,7 +6,7 @@ module Oracles (
     module Oracles.LookupInPath,
     module Oracles.PackageData,
     module Oracles.PackageDeps,
-    module Oracles.WindowsRoot
+    module Oracles.WindowsPath
     ) where
 
 import Oracles.Config
@@ -16,4 +16,4 @@ import Oracles.Dependencies
 import Oracles.LookupInPath
 import Oracles.PackageData
 import Oracles.PackageDeps
-import Oracles.WindowsRoot
+import Oracles.WindowsPath
diff --git a/src/Oracles/WindowsPath.hs b/src/Oracles/WindowsPath.hs
new file mode 100644
index 0000000..189c329
--- /dev/null
+++ b/src/Oracles/WindowsPath.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+module Oracles.WindowsPath (
+    fixAbsolutePathOnWindows, topDirectory, windowsPathOracle
+    ) where
+
+import Data.Char (isSpace)
+import Base
+import Oracles.Config.Setting
+
+newtype WindowsPath = WindowsPath FilePath
+    deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+
+topDirectory :: Action FilePath
+topDirectory = do
+    ghcSourcePath <- setting GhcSourcePath
+    fixAbsolutePathOnWindows ghcSourcePath
+
+-- 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
+
+-- Detecting path mapping on Windows. This is slow and requires caching.
+windowsPathOracle :: Rules ()
+windowsPathOracle = do
+    answer <- newCache $ \path -> do
+        Stdout out <- quietly $ cmd ["cygpath", "-m", path]
+        let windowsPath = dropWhileEnd isSpace out
+        putOracle $ "Windows path mapping: " ++ path ++ " => " ++ windowsPath
+        return windowsPath
+    _ <- addOracle $ \(WindowsPath query) -> answer query
+    return ()
diff --git a/src/Oracles/WindowsRoot.hs b/src/Oracles/WindowsRoot.hs
deleted file mode 100644
index 413f289..0000000
--- a/src/Oracles/WindowsRoot.hs
+++ /dev/null
@@ -1,51 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-module Oracles.WindowsRoot (
-    windowsRoot, fixAbsolutePathOnWindows, topDirectory, windowsRootOracle
-    ) where
-
-import Data.Char (isSpace)
-import Base
-import Oracles.Config.Setting
-
-newtype WindowsRoot = WindowsRoot ()
-    deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
-
--- Looks up cygwin/msys root on Windows
-windowsRoot :: Action String
-windowsRoot = askOracle $ WindowsRoot ()
-
-topDirectory :: Action FilePath
-topDirectory = do
-    ghcSourcePath <- setting GhcSourcePath
-    fixAbsolutePathOnWindows ghcSourcePath
-
--- TODO: this is fragile, e.g. we currently only handle C: drive
--- On Windows:
--- * if the path starts with "/c/" change the prefix to "C:/"
--- * otherwise, if the path starts with "/", prepend it with the correct path
--- to the root, e.g: "/usr/local/bin/ghc.exe" => "C:/msys/usr/local/bin/ghc.exe"
-fixAbsolutePathOnWindows :: FilePath -> Action FilePath
-fixAbsolutePathOnWindows path = do
-    windows <- windowsHost
-    -- Note, below is different from FilePath.isAbsolute:
-    if (windows && "/" `isPrefixOf` path)
-    then do
-        if ("/c/" `isPrefixOf` path)
-        then return $ "C:" ++ drop 2 path
-        else do
-            root <- windowsRoot
-            return . unifyPath $ root ++ drop 1 path
-    else
-        return path
-
--- Oracle for windowsRoot. This operation requires caching as looking up
--- the root is slow (at least the current implementation).
-windowsRootOracle :: Rules ()
-windowsRootOracle = do
-    root <- newCache $ \_ -> do
-        Stdout out <- quietly $ cmd ["cygpath", "-m", "/"]
-        let root = dropWhileEnd isSpace out
-        putOracle $ "Detected root on Windows: " ++ root
-        return root
-    _ <- addOracle $ \WindowsRoot{} -> root ()
-    return ()
diff --git a/src/Rules/Oracles.hs b/src/Rules/Oracles.hs
index 55f7aee..1bc1606 100644
--- a/src/Rules/Oracles.hs
+++ b/src/Rules/Oracles.hs
@@ -17,4 +17,4 @@ oracleRules = do
     packageDataOracle  -- see Oracles.PackageData
     packageDbOracle    -- see Oracles.PackageData
     packageDepsOracle  -- see Oracles.PackageDeps
-    windowsRootOracle  -- see Oracles.WindowsRoot
+    windowsPathOracle  -- see Oracles.WindowsRoot
diff --git a/src/Test.hs b/src/Test.hs
index a79c9fc..f8e93e7 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -6,7 +6,7 @@ import Expression
 import GHC (rts, libffi)
 import Oracles.Config.Flag
 import Oracles.Config.Setting
-import Oracles.WindowsRoot -- TODO: rename to Oracles.TopDirectory
+import Oracles.WindowsPath
 import Rules.Actions
 import Settings.Packages
 import Settings.User