Commit 5bc7a0ae authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add topDirectory function instead of less reliable GhcSourcePath.

parent 19310e7f
......@@ -118,25 +118,6 @@ needBuilder laxDependencies builder = do
GhcM _ -> True
_ -> False
-- 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
-- Instances for storing in the Shake database
instance Binary Builder
instance Hashable Builder
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.WindowsRoot (windowsRoot, windowsRootOracle) where
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)
......@@ -11,6 +14,30 @@ newtype WindowsRoot = WindowsRoot ()
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 ()
......
......@@ -8,8 +8,8 @@ import qualified System.Directory as IO
import Base
import Expression
import Oracles
import Oracles.ArgsHash
import Oracles.Config.Setting
import Settings
import Settings.Args
import Settings.Builders.Ar
......@@ -37,7 +37,7 @@ buildWithResources rs target = do
then arCmd path argList
else do
input <- interpret target getInput
top <- setting GhcSourcePath
top <- topDirectory
cmd [path] [Cwd output] "x" (top -/- input)
HsCpp -> captureStdout target path argList
......
......@@ -3,7 +3,7 @@ module Rules.Libffi (libffiRules, libffiLibrary) where
import Base
import Expression
import GHC
import Oracles.Config.Setting
import Oracles
import Rules.Actions
import Settings.Builders.Common
import Settings.User
......@@ -51,7 +51,7 @@ configureEnvironment = do
configureArguments :: Action [String]
configureArguments = do
top <- setting GhcSourcePath
top <- topDirectory
targetPlatform <- setting TargetPlatform
return [ "--prefix=" ++ top ++ "/libffi/build/inst"
, "--libdir=" ++ top ++ "/libffi/build/inst/lib"
......
......@@ -2,12 +2,12 @@ module Rules.Wrappers.Ghc (ghcWrapper) where
import Base
import Expression
import Oracles
import Settings
ghcWrapper :: FilePath -> Expr String
ghcWrapper program = do
lift $ need [sourcePath -/- "Rules/Wrappers/Ghc.hs"]
top <- getSetting GhcSourcePath
top <- getTopDirectory
return $ unlines
[ "#!/bin/bash"
, "exec " ++ (top -/- program)
......
......@@ -2,12 +2,12 @@ module Rules.Wrappers.GhcPkg (ghcPkgWrapper) where
import Base
import Expression
import Oracles
import Settings
ghcPkgWrapper :: FilePath -> Expr String
ghcPkgWrapper program = do
lift $ need [sourcePath -/- "Rules/Wrappers/GhcPkg.hs"]
top <- getSetting GhcSourcePath
top <- getTopDirectory
stage <- getStage
-- Use the package configuration for the next stage in the wrapper.
-- The wrapper is generated in StageN, but used in StageN+1.
......
......@@ -3,7 +3,7 @@ module Settings (
module Settings.TargetDirectory,
module Settings.User,
module Settings.Ways,
getPkgData, getPkgDataList, programPath, isLibrary,
getPkgData, getPkgDataList, getTopDirectory, programPath, isLibrary,
getPackagePath, getTargetDirectory, getTargetPath, getPackageSources
) where
......@@ -31,6 +31,9 @@ getPkgData key = lift . pkgData . key =<< getTargetPath
getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
getPkgDataList key = lift . pkgDataList . key =<< getTargetPath
getTopDirectory :: Expr FilePath
getTopDirectory = lift topDirectory
programPath :: Stage -> Package -> Maybe FilePath
programPath = userProgramPath
......
......@@ -90,7 +90,7 @@ bootPackageDbArgs = do
stage <- getStage
lift $ need [packageConfigurationInitialised stage]
stage0 ? do
path <- getSetting GhcSourcePath
path <- getTopDirectory
prefix <- ifM builderGhc (return "-package-db ") (return "--package-db=")
arg $ prefix ++ path -/- packageConfiguration Stage0
......@@ -117,7 +117,7 @@ withBuilderKey b = case b of
-- Expression 'with Gcc' appends "--with-gcc=/path/to/gcc" and needs Gcc.
with :: Builder -> Args
with b = specified b ? do
top <- getSetting GhcSourcePath
top <- getTopDirectory
path <- getBuilderPath b
lift $ needBuilder laxDependencies b
append [withBuilderKey b ++ top -/- path]
......
......@@ -20,7 +20,7 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do
gmpDirs <- getSettingList GmpIncludeDirs
cFlags <- getCFlags
lFlags <- getLFlags
top <- getSetting GhcSourcePath
top <- getTopDirectory
hArch <- getSetting HostArch
hOs <- getSetting HostOs
tArch <- getSetting TargetArch
......
......@@ -42,7 +42,7 @@ rtsPackageArgs = package rts ? do
ghcEnableTNC <- yesNo ghcEnableTablesNextToCode
way <- getWay
path <- getTargetPath
top <- getSetting GhcSourcePath
top <- getTopDirectory
libffiName <- lift $ rtsLibffiLibraryName
mconcat
[ builderGcc ? mconcat
......
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