Commit 179d1cd8 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add -/- for combining paths with unification of the result.

parent fcb25e6e
......@@ -5,7 +5,6 @@ module Oracles.Base (
module Development.Shake.Util,
module Development.Shake.Config,
module Development.Shake.Classes,
module Development.Shake.FilePath,
askConfigWithDefault, askConfig, configOracle,
configPath,
putOracle
......@@ -18,11 +17,10 @@ import Development.Shake
import Development.Shake.Util
import Development.Shake.Config
import Development.Shake.Classes
import Development.Shake.FilePath
import qualified Data.HashMap.Strict as Map
configPath :: FilePath
configPath = "shake" </> "cfg"
configPath = "shake" -/- "cfg"
newtype ConfigKey = ConfigKey String
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
......@@ -41,13 +39,13 @@ askConfig key = askConfigWithDefault key . redError
-- Oracle for configuration files
configOracle :: Rules ()
configOracle = do
let configFile = configPath </> "system.config"
let configFile = configPath -/- "system.config"
cfg <- newCache $ \() -> do
unlessM (doesFileExist $ configFile <.> "in") $
redError_ $ "\nConfiguration file '" ++ (configFile <.> "in")
++ "' is missing; unwilling to proceed."
need [configFile]
putOracle $ "Reading " ++ unifyPath configFile ++ "..."
putOracle $ "Reading " ++ configFile ++ "..."
liftIO $ readConfigFile configFile
addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()
return ()
......
......@@ -43,7 +43,7 @@ newtype PackageDataKey = PackageDataKey (FilePath, String)
askPackageData :: FilePath -> String -> Action String
askPackageData path key = do
let fullKey = replaceSeparators '_' $ path ++ "_" ++ key
pkgData = path </> "package-data.mk"
pkgData = path -/- "package-data.mk"
value <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ fromMaybe
(error $ "No key '" ++ key ++ "' in " ++ pkgData ++ ".") value
......@@ -55,10 +55,10 @@ pkgData packageData = do
PackageKey path -> ("PACKAGE_KEY" , path)
Synopsis path -> ("SYNOPSIS" , path)
fullKey = replaceSeparators '_' $ path ++ "_" ++ key
pkgData = path </> "package-data.mk"
pkgData = path -/- "package-data.mk"
res <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ fromMaybe
(error $ "No key '" ++ key ++ "' in " ++ unifyPath pkgData ++ ".") res
(error $ "No key '" ++ key ++ "' in " ++ pkgData ++ ".") res
pkgDataList :: PackageDataList -> Action [String]
pkgDataList packageData = do
......@@ -75,12 +75,11 @@ pkgDataList packageData = do
CSrcs path -> ("C_SRCS" , path, "" )
DepIncludeDirs path -> ("DEP_INCLUDE_DIRS_SINGLE_QUOTED", path, "" )
fullKey = replaceSeparators '_' $ path ++ "_" ++ key
pkgData = path </> "package-data.mk"
pkgData = path -/- "package-data.mk"
unquote = dropWhile (== '\'') . dropWhileEnd (== '\'')
res <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ map unquote $ words $ case res of
Nothing -> error $ "No key '" ++ key ++ "' in "
++ unifyPath pkgData ++ "."
Nothing -> error $ "No key '" ++ key ++ "' in " ++ pkgData ++ "."
Just "" -> defaultValue
Just value -> value
......
......@@ -28,7 +28,7 @@ instance Ord Package where
-- TODO: check if unifyPath is actually needed
library :: String -> Package
library name =
Package name (unifyPath $ "libraries" </> name) (name <.> "cabal")
Package name ("libraries" -/- name) (name <.> "cabal")
topLevel :: String -> Package
topLevel name = Package name name (name <.> "cabal")
......
......@@ -4,6 +4,7 @@ module Rules (
module Rules.Config,
) where
import Util
import Stage
import Expression
import Rules.Config
......@@ -12,7 +13,6 @@ import Rules.Oracles
import Settings.Packages
import Settings.TargetDirectory
import Development.Shake
import Development.Shake.FilePath
-- generateTargets needs package-data.mk files of all target packages
-- TODO: make interpretDiff total
......@@ -21,7 +21,7 @@ generateTargets = action $
forM_ [Stage0 ..] $ \stage -> do
pkgs <- interpret (stageTarget stage) packages
forM_ pkgs $ \pkg -> do
need [targetPath stage pkg </> "package-data.mk"]
need [targetPath stage pkg -/- "package-data.mk"]
-- TODO: add Stage2 (compiler only?)
packageRules :: Rules ()
......
......@@ -7,12 +7,12 @@ import Oracles.Base
configRules :: Rules ()
configRules = do
configPath </> "system.config" %> \out -> do
need [configPath </> "system.config.in", "configure"]
configPath -/- "system.config" %> \out -> do
need [configPath -/- "system.config.in", "configure"]
putColoured White "Running configure..."
cmd "bash configure" -- TODO: get rid of 'bash'
"configure" %> \out -> do
copyFile' (configPath </> "configure.ac") "configure.ac"
copyFile' (configPath -/- "configure.ac") "configure.ac"
putColoured White $ "Running autoconf..."
cmd "bash autoconf" -- TODO: get rid of 'bash'
......@@ -24,23 +24,23 @@ buildPackageData target =
pkg = getPackage target
path = targetPath stage pkg
in
(path </>) <$>
(path -/-) <$>
[ "package-data.mk"
, "haddock-prologue.txt"
, "inplace-pkg-config"
, "setup-config"
, "build" </> "autogen" </> "cabal_macros.h"
, "build" -/- "autogen" -/- "cabal_macros.h"
-- TODO: Is this needed? Also check out Paths_cpsa.hs.
-- , "build" </> "autogen" </> ("Paths_" ++ name) <.> "hs"
-- , "build" -/- "autogen" -/- ("Paths_" ++ name) <.> "hs"
] &%> \files -> do
let configure = pkgPath pkg </> "configure"
let configure = pkgPath pkg -/- "configure"
-- GhcCabal will run the configure script, so we depend on it
need [pkgPath pkg </> pkgCabal pkg]
need [pkgPath pkg -/- pkgCabal pkg]
-- We still don't know who built the configure script from configure.ac
whenM (doesFileExist $ configure <.> "ac") $ need [configure]
build $ fullTarget target files GhcCabal
buildWhen registerPackage $ fullTarget target files (GhcPkg stage)
postProcessPackageData $ path </> "package-data.mk"
postProcessPackageData $ path -/- "package-data.mk"
-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
-- 1) Drop lines containing '$'
......
......@@ -24,8 +24,8 @@ cabalArgs = builder GhcCabal ? do
stage <- asks getStage
pkg <- asks getPackage
mconcat [ arg "configure"
, argPath $ pkgPath pkg
, argPath $ targetDirectory stage pkg
, arg $ pkgPath pkg
, arg $ targetDirectory stage pkg
, dllArgs
, with $ Ghc stage
, with $ GhcPkg stage
......@@ -83,7 +83,7 @@ configureArgs = do
bootPackageDbArgs :: Args
bootPackageDbArgs = do
sourcePath <- lift . setting $ GhcSourcePath
arg $ "--package-db=" ++ sourcePath </> "libraries/bootstrapping.conf"
arg $ "--package-db=" ++ sourcePath -/- "libraries/bootstrapping.conf"
-- This is a positional argument, hence:
-- * if it is empty, we need to emit one empty string argument;
......@@ -95,7 +95,7 @@ packageConstraints :: Args
packageConstraints = do
pkgs <- fromDiffExpr packages
constraints <- lift $ forM pkgs $ \pkg -> do
let cabal = pkgPath pkg </> pkgCabal pkg
let cabal = pkgPath pkg -/- pkgCabal pkg
prefix = dropExtension (pkgCabal pkg) ++ " == "
need [cabal]
content <- lines <$> liftIO (readFile cabal)
......
......@@ -23,7 +23,7 @@ ghcMArgs = do
hsArgs <- askPkgDataList HsArgs
hsSrcs <- askHsSources
ways <- fromDiffExpr Settings.Ways.ways
let buildPath = unifyPath $ targetPath stage pkg </> "build"
let buildPath = targetPath stage pkg -/- "build"
mconcat
[ arg "-M"
, packageGhcArgs
......@@ -32,7 +32,7 @@ ghcMArgs = do
, arg $ "-odir " ++ buildPath
, arg $ "-stubdir " ++ buildPath
, arg $ "-hidir " ++ buildPath
, arg $ "-dep-makefile " ++ buildPath </> "haskell.deps"
, arg $ "-dep-makefile " ++ buildPath -/- "haskell.deps"
, append . map (\way -> "-dep-suffix " ++ wayPrefix way) $ ways
, append hsArgs
, append hsSrcs ]
......@@ -61,33 +61,33 @@ includeGhcArgs = do
pkg <- asks getPackage
srcDirs <- askPkgDataList SrcDirs
includeDirs <- askPkgDataList IncludeDirs
let buildPath = unifyPath $ targetPath stage pkg </> "build"
autogenPath = unifyPath $ buildPath </> "autogen"
let buildPath = targetPath stage pkg -/- "build"
autogenPath = buildPath -/- "autogen"
mconcat
[ arg "-i"
, append . map (\dir -> "-i" ++ pkgPath pkg </> dir) $ srcDirs
, append . map (\dir -> "-i" ++ pkgPath pkg -/- dir) $ srcDirs
, arg $ "-i" ++ buildPath
, arg $ "-i" ++ autogenPath
, arg $ "-I" ++ buildPath
, arg $ "-I" ++ autogenPath
, append . map (\dir -> "-I" ++ pkgPath pkg </> dir) $ includeDirs
, append . map (\dir -> "-I" ++ pkgPath pkg -/- dir) $ includeDirs
, arg "-optP-include" -- TODO: Shall we also add -cpp?
, arg $ "-optP" ++ autogenPath </> "cabal_macros.h" ]
, arg $ "-optP" ++ autogenPath -/- "cabal_macros.h" ]
askHsSources :: Expr [FilePath]
askHsSources = do
stage <- asks getStage
pkg <- asks getPackage
srcDirs <- askPkgDataList SrcDirs
let autogenPath = unifyPath $ targetPath stage pkg </> "build/autogen"
dirs = autogenPath : map (pkgPath pkg </>) srcDirs
let autogenPath = targetPath stage pkg -/- "build/autogen"
dirs = autogenPath : map (pkgPath pkg -/-) srcDirs
askModuleFiles dirs [".hs", ".lhs"]
askModuleFiles :: [FilePath] -> [String] -> Expr [FilePath]
askModuleFiles directories suffixes = do
modules <- askPkgDataList Modules
let modPaths = map (replaceEq '.' pathSeparator) modules
files <- lift $ forM [ dir </> modPath ++ suffix
files <- lift $ forM [ dir -/- modPath ++ suffix
| dir <- directories
, modPath <- modPaths
, suffix <- suffixes
......
......@@ -2,13 +2,13 @@ module Settings.GhcPkg (
ghcPkgArgs
) where
import Util
import Builder
import Switches
import Expression
import Settings.Util
import Settings.GhcCabal
import Settings.TargetDirectory
import Development.Shake.FilePath
ghcPkgArgs :: Args
ghcPkgArgs = do
......@@ -18,4 +18,4 @@ ghcPkgArgs = do
[ arg "update"
, arg "--force"
, stage0 ? bootPackageDbArgs
, argPath $ targetPath stage pkg </> "inplace-pkg-config" ]
, arg $ targetPath stage pkg -/- "inplace-pkg-config" ]
......@@ -2,10 +2,10 @@ module Settings.TargetDirectory (
targetDirectory, targetPath
) where
import Util
import Stage
import Package
import Settings.User
import Development.Shake.FilePath
-- User can override the default target directory settings given below
targetDirectory :: Stage -> Package -> FilePath
......@@ -13,4 +13,4 @@ targetDirectory = userTargetDirectory
-- Path to the target directory from GHC source root
targetPath :: Stage -> Package -> FilePath
targetPath stage pkg = pkgPath pkg </> targetDirectory stage pkg
targetPath stage pkg = pkgPath pkg -/- targetDirectory stage pkg
module Settings.Util (
-- Primitive settings elements
arg, argPath, argM,
arg, argM,
argSetting, argSettingList,
askPkgData, askPkgDataList,
appendCcArgs,
......@@ -13,7 +13,6 @@ module Settings.Util (
-- argPackageConstraints,
) where
import Util
import Builder
import Expression
import Oracles.Base
......@@ -26,10 +25,6 @@ import Settings.TargetDirectory
arg :: String -> Args
arg = append . return
-- A single path argument. The path gets unified.
argPath :: String -> Args
argPath = append . return . unifyPath
argM :: Action String -> Args
argM = appendM . fmap return
......
......@@ -3,7 +3,7 @@ module Util (
module System.Console.ANSI,
module Development.Shake.FilePath,
replaceIf, replaceEq, replaceSeparators,
unifyPath,
unifyPath, (-/-),
chunksOfSize,
putColoured, redError, redError_
) where
......@@ -24,9 +24,16 @@ replaceEq from = replaceIf (== from)
replaceSeparators :: Char -> String -> String
replaceSeparators = replaceIf isPathSeparator
-- Normalise a path and convert all path separators to /, even on Windows.
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx
-- Combine paths using </> and apply unifyPath to the result
(-/-) :: FilePath -> FilePath -> FilePath
a -/- b = unifyPath $ a </> b
infixr 5 -/-
-- (chunksOfSize size ss) splits a list of strings 'ss' into chunks not
-- exceeding the given 'size'.
chunksOfSize :: Int -> [String] -> [[String]]
......
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