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

Add Util/unifyPath function and make sure it is used.

parent 4399476d
......@@ -35,13 +35,13 @@ configOracle = do
++ (defaultConfig <.> "in")
++ "' is missing; unwilling to proceed."
need [defaultConfig]
putOracle $ "Parsing " ++ toStandard defaultConfig ++ "..."
putOracle $ "Parsing " ++ unifyPath defaultConfig ++ "..."
cfgDefault <- liftIO $ readConfigFile defaultConfig
existsUser <- doesFileExist userConfig
cfgUser <- if existsUser
then do
putOracle $ "Parsing "
++ toStandard userConfig ++ "..."
++ unifyPath userConfig ++ "..."
liftIO $ readConfigFile userConfig
else do
putColoured Red $
......@@ -59,9 +59,10 @@ packageDataOracle :: Rules ()
packageDataOracle = do
pkgData <- newCache $ \file -> do
need [file]
putOracle $ "Parsing " ++ toStandard file ++ "..."
putOracle $ "Parsing " ++ file ++ "..."
liftIO $ readConfigFile file
addOracle $ \(PackageDataKey (file, key)) -> M.lookup key <$> pkgData file
addOracle $ \(PackageDataKey (file, key)) ->
M.lookup key <$> pkgData (unifyPath file)
return ()
-- Oracle for 'path/dist/*.deps' files
......@@ -72,12 +73,12 @@ dependencyOracle = do
putOracle $ "Parsing " ++ file ++ "..."
contents <- parseMakefile <$> (liftIO $ readFile file)
return $ M.fromList
$ map (bimap toStandard (map toStandard))
$ map (bimap unifyPath (map unifyPath))
$ map (bimap head concat . unzip)
$ groupBy ((==) `on` fst)
$ sortBy (compare `on` fst) contents
addOracle $ \(DependencyListKey (file, obj)) ->
M.lookup (toStandard obj) <$> deps (toStandard file)
M.lookup (unifyPath obj) <$> deps (unifyPath file)
return ()
oracleRules :: Rules ()
......
......@@ -47,7 +47,7 @@ instance ShowArg PackageData where
pkgData = path </> "package-data.mk"
res <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ fromMaybe
(error $ "No key '" ++ key ++ "' in " ++ toStandard pkgData ++ ".")
(error $ "No key '" ++ key ++ "' in " ++ unifyPath pkgData ++ ".")
res
instance ShowArgs MultiPackageData where
......@@ -68,6 +68,6 @@ instance ShowArgs MultiPackageData where
res <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ words $ case res of
Nothing -> error $ "No key '" ++ key ++ "' in "
++ toStandard pkgData ++ "."
++ unifyPath pkgData ++ "."
Just "" -> defaultValue
Just value -> value
......@@ -52,7 +52,7 @@ libraryPackage :: String -> [Stage] -> (Stage -> Settings) -> Package
libraryPackage name stages settings =
Package
name
("libraries" </> name)
(unifyPath $ "libraries" </> name)
[ (stage
, if stage == Stage0 then "dist-boot" else "dist-install"
, settings stage)
......@@ -75,8 +75,7 @@ commonCcWarninigArgs = when Validating $
arg "-Werror=unused-but-set-variable" ]
pathArgs :: ShowArgs a => String -> FilePath -> a -> Args
pathArgs key path as =
map (\a -> key ++ toStandard (normaliseEx $ path </> a)) <$> args as
pathArgs key path as = map (\a -> key ++ unifyPath (path </> a)) <$> args as
packageArgs :: Stage -> FilePath -> Args
packageArgs stage pathDist = do
......@@ -95,15 +94,15 @@ packageArgs stage pathDist = do
includeGhcArgs :: FilePath -> FilePath -> Args
includeGhcArgs path dist =
let pathDist = path </> dist
buildDir = toStandard $ pathDist </> "build"
buildDir = unifyPath $ pathDist </> "build"
in args [ arg "-i"
, pathArgs "-i" path $ SrcDirs pathDist
, concatArgs ["-i", "-I"]
[buildDir, toStandard $ buildDir </> "autogen"]
[buildDir, unifyPath $ buildDir </> "autogen"]
, pathArgs "-I" path $ IncludeDirs pathDist
, arg "-optP-include" -- TODO: Shall we also add -cpp?
, concatArgs "-optP" $
toStandard $ buildDir </> "autogen/cabal_macros.h" ]
unifyPath $ buildDir </> "autogen/cabal_macros.h" ]
pkgHsSources :: FilePath -> FilePath -> Action [FilePath]
pkgHsSources path dist = do
......@@ -118,9 +117,9 @@ pkgDepHsObjects :: FilePath -> FilePath -> Way -> Action [FilePath]
pkgDepHsObjects path dist way = do
let pathDist = path </> dist
buildDir = pathDist </> "build"
dirs <- map (normaliseEx . (path </>)) <$> args (SrcDirs pathDist)
dirs <- map (unifyPath . (path </>)) <$> args (SrcDirs pathDist)
fmap concat $ forM dirs $ \d ->
map (toStandard . (buildDir ++) . (-<.> osuf way) . drop (length d))
map (unifyPath . (buildDir ++) . (-<.> osuf way) . drop (length d))
<$> (findModuleFiles pathDist [d] [".hs", ".lhs"])
pkgCObjects :: FilePath -> FilePath -> Way -> Action [FilePath]
......@@ -128,13 +127,13 @@ pkgCObjects path dist way = do
let pathDist = path </> dist
buildDir = pathDist </> "build"
srcs <- args $ CSrcs pathDist
return $ map (toStandard . (buildDir </>) . (-<.> osuf way)) srcs
return $ map (unifyPath . (buildDir </>) . (-<.> osuf way)) srcs
-- Find Haskell objects that go to library
pkgLibHsObjects :: FilePath -> FilePath -> Stage -> Way -> Action [FilePath]
pkgLibHsObjects path dist stage way = do
let pathDist = path </> dist
buildDir = pathDist </> "build"
buildDir = unifyPath $ pathDist </> "build"
split <- splitObjects stage
if split
then do
......@@ -151,7 +150,7 @@ findModuleFiles pathDist directories suffixes = do
let file = dir </> modPath ++ suffix
when (doesDirectoryExist $ dropFileName file) $ return file
files <- getDirectoryFiles "" $ concat $ concat fileList
return $ map (toStandard . normaliseEx) files
return $ map unifyPath files
-- The argument list has a limited size on Windows. Since Windows 7 the limit
-- is 32768 (theoretically). In practice we use 31000 to leave some breathing
......
......@@ -13,7 +13,7 @@ suffixArgs way =
ghcArgs :: Package -> TodoItem -> Way -> [FilePath] -> FilePath -> Args
ghcArgs (Package _ path _) (stage, dist, _) way srcs result =
let pathDist = path </> dist
buildDir = toStandard $ pathDist </> "build"
buildDir = unifyPath $ pathDist </> "build"
in args [ suffixArgs way
, wayHcArgs way
, args SrcHcArgs
......@@ -40,7 +40,7 @@ gccArgs (Package _ path _) (_, dist, _) srcs result =
buildRule :: Package -> TodoItem -> Rules ()
buildRule pkg @ (Package name path _) todo @ (stage, dist, _) =
let buildDir = toStandard $ path </> dist </> "build"
let buildDir = unifyPath $ path </> dist </> "build"
hDepFile = buildDir </> "haskell.deps"
cDepFile = buildDir </> "c.deps"
in
......@@ -63,10 +63,10 @@ buildRule pkg @ (Package name path _) todo @ (stage, dist, _) =
-- Report impossible cases
when (null $ hSrcs ++ cSrcs)
$ redError_ $ "No source files found for "
++ toStandard obj ++ "."
++ unifyPath obj ++ "."
when (not (null hSrcs) && not (null cSrcs))
$ redError_ $ "Both c and Haskell sources found for "
++ toStandard obj ++ "."
++ unifyPath obj ++ "."
-- Build using appropriate compiler
need $ hDeps ++ cDeps
when (not $ null hSrcs)
......
......@@ -71,13 +71,12 @@ bootPkgConstraints = args $ do
[versionLine] -> args ["--constraint", baseName ++ " == "
++ dropWhile (not . isDigit) versionLine ]
_ -> redError $ "Cannot determine package version in '"
++ toStandard cabal ++ "'."
++ unifyPath cabal ++ "'."
bootPackageDb :: Args
bootPackageDb = do
top <- showArg GhcSourcePath
arg $ toStandard
$ "--package-db=" ++ top </> "libraries/bootstrapping.conf"
arg $ unifyPath $ "--package-db=" ++ top </> "libraries/bootstrapping.conf"
cabalArgs :: Package -> TodoItem -> Args
cabalArgs pkg @ (Package _ path _) todo @ (stage, dist, settings) = args
......@@ -104,7 +103,7 @@ ghcPkgArgs :: Package -> TodoItem -> Args
ghcPkgArgs (Package _ path _) (stage, dist, _) = args $
[ arg "update"
, arg "--force"
, arg $ toStandard $ path </> dist </> "inplace-pkg-config"
, arg $ unifyPath $ path </> dist </> "inplace-pkg-config"
, when (stage == Stage0) bootPackageDb ]
buildRule :: Package -> TodoItem -> Rules ()
......
......@@ -9,7 +9,7 @@ argListDir = "shake/arg/buildPackageDependencies"
ghcArgs :: Package -> TodoItem -> Args
ghcArgs (Package name path _) (stage, dist, settings) =
let pathDist = path </> dist
buildDir = toStandard $ pathDist </> "build"
buildDir = unifyPath $ pathDist </> "build"
depFile = buildDir </> "haskell.deps"
in args [ arg "-M"
, packageArgs stage pathDist
......@@ -52,9 +52,9 @@ gccArgs sourceFile (Package _ path _) (stage, dist, _) =
, commonCcArgs
, commonCcWarninigArgs
, pathArgs "-I" path $ IncludeDirs pathDist
, args ["-MF", toStandard depFile]
, args ["-MF", unifyPath depFile]
, args ["-x", "c"]
, arg $ toStandard sourceFile ]
, arg $ unifyPath sourceFile ]
buildRule :: Package -> TodoItem -> Rules ()
buildRule pkg @ (Package name path _) todo @ (stage, dist, settings) = do
......
......@@ -25,7 +25,7 @@ arRule pkg @ (Package _ path _) todo @ (stage, dist, _) =
-- Splitting argument list into chunks as otherwise Ar chokes up
maxChunk <- argSizeLimit
forM_ (chunksOfSize maxChunk $ libHsObjs ++ cObjs) $ \os -> do
run Ar $ arArgs os $ toStandard out
run Ar $ arArgs os $ unifyPath out
ldArgs :: Package -> TodoItem -> FilePath -> Args
ldArgs (Package _ path _) (stage, dist, _) result = do
......@@ -45,7 +45,7 @@ ldRule pkg @ (Package name path _) todo @ (stage, dist, _) =
in
priority 2 $ (buildDir </> "*.o") %> \out -> do
need [argListPath argListDir pkg stage]
run Ld $ ldArgs pkg todo $ toStandard out
run Ld $ ldArgs pkg todo $ unifyPath out
synopsis <- dropWhileEnd isPunctuation <$> showArg (Synopsis pathDist)
putColoured Green $ "/--------\n| Successfully built package "
++ name ++ " (stage " ++ show stage ++ ")."
......@@ -60,12 +60,12 @@ argListRule pkg @ (Package _ path _) todo @ (stage, dist, settings) =
ldList <- argList Ld (ldArgs pkg todo "output.o")
arList <- forM ways' $ \way -> do
cObjs <- pkgCObjects path dist way
libHsObjs <- pkgLibHsObjects path dist stage way
extension <- libsuf way
hObjs <- pkgLibHsObjects path dist stage way
ext <- libsuf way
argListWithComment
("way '" ++ tag way ++ "'")
Ar
(arArgs (libHsObjs ++ cObjs) $ "output" <.> extension)
(arArgs (hObjs ++ cObjs) $ "output" <.> ext)
writeFileChanged out $ unlines $ [ldList] ++ arList
buildPackageLibrary :: Package -> TodoItem -> Rules ()
......
......@@ -2,6 +2,7 @@ module Util (
module Data.Char,
module System.Console.ANSI,
replaceIf, replaceEq, replaceSeparators,
unifyPath,
chunksOfSize,
putColoured, redError, redError_
) where
......@@ -21,6 +22,9 @@ replaceEq from = replaceIf (== from)
replaceSeparators :: Char -> String -> String
replaceSeparators = replaceIf isPathSeparator
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx
-- (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