Commit f5299c86 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Implement path lookup on Windows.

parent 2fe68f0a
......@@ -34,7 +34,7 @@ executable ghc-shake
, Oracles.PackageData
, Oracles.PackageDb
, Oracles.PackageDeps
, Oracles.WindowsRoot
, Oracles.WindowsPath
, Package
, Predicates
, Rules
......
......@@ -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
{-# 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 ()
{-# 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 ()
......@@ -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
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment