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

Clean up code, do renaming.

parent 4914709c
...@@ -10,7 +10,7 @@ module Expression ( ...@@ -10,7 +10,7 @@ module Expression (
appendSub, appendSubD, filterSub, removeSub, appendSub, appendSubD, filterSub, removeSub,
interpret, interpretDiff, interpret, interpretDiff,
getStage, getPackage, getBuilder, getFiles, getFile, getStage, getPackage, getBuilder, getFiles, getFile,
getDependencies, getDependency, getWay, getSources, getSource, getWay,
stage, package, builder, stagedBuilder, file, way stage, package, builder, stagedBuilder, file, way
) where ) where
...@@ -162,6 +162,20 @@ getPackage = asks Target.package ...@@ -162,6 +162,20 @@ getPackage = asks Target.package
getBuilder :: Expr Builder getBuilder :: Expr Builder
getBuilder = asks Target.builder getBuilder = asks Target.builder
getWay :: Expr Way
getWay = asks Target.way
getSources :: Expr [FilePath]
getSources = asks Target.sources
getSource :: Expr FilePath
getSource = do
target <- ask
srcs <- getSources
case srcs of
[src] -> return src
_ -> error $ "Exactly one source expected in target " ++ show target
getFiles :: Expr [FilePath] getFiles :: Expr [FilePath]
getFiles = asks Target.files getFiles = asks Target.files
...@@ -174,21 +188,6 @@ getFile = do ...@@ -174,21 +188,6 @@ getFile = do
[file] -> return file [file] -> return file
_ -> error $ "Exactly one file expected in target " ++ show target _ -> error $ "Exactly one file expected in target " ++ show target
getDependencies :: Expr [FilePath]
getDependencies = asks Target.dependencies
getDependency :: Expr FilePath
getDependency = do
target <- ask
deps <- getDependencies
case deps of
[dep] -> return dep
_ -> error $ "Exactly one dependency expected in target "
++ show target
getWay :: Expr Way
getWay = asks Target.way
-- Basic predicates (see Switches.hs for derived predicates) -- Basic predicates (see Switches.hs for derived predicates)
stage :: Stage -> Predicate stage :: Stage -> Predicate
stage s = liftM (s ==) getStage stage s = liftM (s ==) getStage
......
...@@ -6,7 +6,7 @@ import Util ...@@ -6,7 +6,7 @@ import Util
import Builder import Builder
import Expression import Expression
import qualified Target import qualified Target
import Oracles.DependencyList import Oracles.Dependencies
import Settings.TargetDirectory import Settings.TargetDirectory
import Rules.Actions import Rules.Actions
import Rules.Resources import Rules.Resources
...@@ -27,29 +27,16 @@ compilePackage _ target = do ...@@ -27,29 +27,16 @@ compilePackage _ target = do
need [ hiboot -<.> obootsuf (detectWay hiboot) ] need [ hiboot -<.> obootsuf (detectWay hiboot) ]
matchBuildResult buildPath "o" ?> \obj -> do matchBuildResult buildPath "o" ?> \obj -> do
cDeps <- dependencyList cDepsFile (takeFileName obj -<.> "o") (src, deps) <- dependencies buildPath obj
if not (null cDeps) need deps
then do -- obj is produced from a C source file if ("//*.c" ?== src)
need cDeps then build $ fullTarget target (Gcc stage) [src] [obj]
build $ fullTarget target cDeps (Gcc stage) [obj] else do
else do -- obj is produced from a Haskell source file let way = detectWay obj
hDeps <- dependencyList hDepsFile obj build $ fullTargetWithWay target (Ghc stage) way [src] [obj]
when (null hDeps) . putError $
"No dependencies found for '" ++ obj ++ "'."
let way = detectWay obj
hSrc = head hDeps
unless ("//*hs" ?== hSrc) . putError $
"No Haskell source file found for '" ++ obj ++ "'."
need hDeps
build $ fullTargetWithWay target [hSrc] (Ghc stage) way [obj]
matchBuildResult buildPath "o-boot" ?> \obj -> do matchBuildResult buildPath "o-boot" ?> \obj -> do
hDeps <- dependencyList hDepsFile obj (src, deps) <- dependencies buildPath obj
when (null hDeps) . putError $ need deps
"No dependencies found for '" ++ obj ++ "'." let way = detectWay obj
let way = detectWay obj build $ fullTargetWithWay target (Ghc stage) way [src] [obj]
hSrc = head hDeps
unless ("//*.hs-boot" ?== hSrc) . putError $
"No Haskell source file found for '" ++ obj ++ "'."
need hDeps
build $ fullTargetWithWay target [hSrc] (Ghc stage) way [obj]
...@@ -47,12 +47,12 @@ buildPackageData (Resources ghcCabal ghcPkg) target = do ...@@ -47,12 +47,12 @@ buildPackageData (Resources ghcCabal ghcPkg) target = do
need [cabal] need [cabal]
buildWithResources [(ghcCabal, 1)] $ buildWithResources [(ghcCabal, 1)] $
fullTarget target [cabal] GhcCabal files fullTarget target GhcCabal [cabal] files
-- TODO: find out of ghc-cabal can be concurrent with ghc-pkg -- TODO: find out of ghc-cabal can be concurrent with ghc-pkg
whenM (interpret target registerPackage) . whenM (interpret target registerPackage) .
buildWithResources [(ghcPkg, 1)] $ buildWithResources [(ghcPkg, 1)] $
fullTarget target [cabal] (GhcPkg stage) files fullTarget target (GhcPkg stage) [cabal] files
postProcessPackageData $ path -/- "package-data.mk" postProcessPackageData $ path -/- "package-data.mk"
......
...@@ -46,7 +46,7 @@ buildPackageLibrary _ target = do ...@@ -46,7 +46,7 @@ buildPackageLibrary _ target = do
. filter (not . all (== '.')) $ contents . filter (not . all (== '.')) $ contents
else return [] else return []
build $ fullTarget target (cObjs ++ hObjs ++ splitObjs) Ar [a] build $ fullTarget target Ar (cObjs ++ hObjs ++ splitObjs) [a]
synopsis <- interpret target $ getPkgData Synopsis synopsis <- interpret target $ getPkgData Synopsis
putSuccess $ "/--------\n| Successfully built package library '" putSuccess $ "/--------\n| Successfully built package library '"
...@@ -64,4 +64,4 @@ buildPackageLibrary _ target = do ...@@ -64,4 +64,4 @@ buildPackageLibrary _ target = do
cObjs = [ buildPath -/- src -<.> "o" | src <- cSrcs ] cObjs = [ buildPath -/- src -<.> "o" | src <- cSrcs ]
hObjs = [ buildPath -/- src <.> "o" | src <- hSrcs ] hObjs = [ buildPath -/- src <.> "o" | src <- hSrcs ]
need $ cObjs ++ hObjs need $ cObjs ++ hObjs
build $ fullTarget target (cObjs ++ hObjs) Ld [obj] build $ fullTarget target Ld (cObjs ++ hObjs) [obj]
...@@ -8,13 +8,13 @@ import Oracles.ArgsHash ...@@ -8,13 +8,13 @@ import Oracles.ArgsHash
import Oracles.PackageData import Oracles.PackageData
import Oracles.WindowsRoot import Oracles.WindowsRoot
import Oracles.PackageDeps import Oracles.PackageDeps
import Oracles.DependencyList import Oracles.Dependencies
oracleRules :: Rules () oracleRules :: Rules ()
oracleRules = do oracleRules = do
configOracle -- see Oracles.Base configOracle -- see Oracles.Base
packageDataOracle -- see Oracles.PackageData packageDataOracle -- see Oracles.PackageData
packageDepsOracle -- see Oracles.PackageDeps packageDepsOracle -- see Oracles.PackageDeps
dependencyListOracle -- see Oracles.DependencyList dependenciesOracle -- see Oracles.Dependencies
argsHashOracle -- see Oracles.ArgsHash argsHashOracle -- see Oracles.ArgsHash
windowsRootOracle -- see Oracles.WindowsRoot windowsRootOracle -- see Oracles.WindowsRoot
...@@ -6,8 +6,8 @@ import Settings.Util ...@@ -6,8 +6,8 @@ import Settings.Util
arArgs :: Args arArgs :: Args
arArgs = builder Ar ? do arArgs = builder Ar ? do
objs <- getDependencies
file <- getFile file <- getFile
objs <- getSources
mconcat [ arg "q" mconcat [ arg "q"
, arg file , arg file
, append objs ] , append objs ]
......
...@@ -12,12 +12,12 @@ gccArgs :: Args ...@@ -12,12 +12,12 @@ gccArgs :: Args
gccArgs = stagedBuilder Gcc ? do gccArgs = stagedBuilder Gcc ? do
path <- getTargetPath path <- getTargetPath
file <- getFile file <- getFile
deps <- getDependencies src <- getSource
ccArgs <- getPkgDataList CcArgs ccArgs <- getPkgDataList CcArgs
mconcat [ append ccArgs mconcat [ append ccArgs
, includeGccArgs , includeGccArgs
, arg "-c" , arg "-c"
, append $ filter ("//*.c" ?==) deps , arg src
, arg "-o" , arg "-o"
, arg file ] , arg file ]
...@@ -26,7 +26,7 @@ gccMArgs :: Args ...@@ -26,7 +26,7 @@ gccMArgs :: Args
gccMArgs = stagedBuilder GccM ? do gccMArgs = stagedBuilder GccM ? do
path <- getTargetPath path <- getTargetPath
file <- getFile file <- getFile
src <- getDependency src <- getSource
ccArgs <- getPkgDataList CcArgs ccArgs <- getPkgDataList CcArgs
mconcat mconcat
[ arg "-E" [ arg "-E"
...@@ -35,6 +35,8 @@ gccMArgs = stagedBuilder GccM ? do ...@@ -35,6 +35,8 @@ gccMArgs = stagedBuilder GccM ? do
, includeGccArgs , includeGccArgs
, arg "-MF" , arg "-MF"
, arg file , arg file
, arg "-MT"
, arg $ dropExtension file -<.> "o"
, arg "-x" , arg "-x"
, arg "c" , arg "c"
, arg src ] , arg src ]
......
...@@ -22,7 +22,7 @@ ghcArgs = stagedBuilder Ghc ? do ...@@ -22,7 +22,7 @@ ghcArgs = stagedBuilder Ghc ? do
way <- getWay way <- getWay
hsArgs <- getPkgDataList HsArgs hsArgs <- getPkgDataList HsArgs
cppArgs <- getPkgDataList CppArgs cppArgs <- getPkgDataList CppArgs
srcs <- getDependencies srcs <- getSources
file <- getFile file <- getFile
path <- getTargetPath path <- getTargetPath
let buildPath = path -/- "build" let buildPath = path -/- "build"
...@@ -47,7 +47,8 @@ ghcArgs = stagedBuilder Ghc ? do ...@@ -47,7 +47,8 @@ ghcArgs = stagedBuilder Ghc ? do
ghcMArgs :: Args ghcMArgs :: Args
ghcMArgs = stagedBuilder GhcM ? do ghcMArgs = stagedBuilder GhcM ? do
ways <- getWays ways <- getWays
hsSrcs <- getHsSources file <- getFile
srcs <- getSources
hsArgs <- getPkgDataList HsArgs hsArgs <- getPkgDataList HsArgs
cppArgs <- getPkgDataList CppArgs cppArgs <- getPkgDataList CppArgs
path <- getTargetPath path <- getTargetPath
...@@ -61,11 +62,11 @@ ghcMArgs = stagedBuilder GhcM ? do ...@@ -61,11 +62,11 @@ ghcMArgs = stagedBuilder GhcM ? do
, arg "-odir" , arg buildPath , arg "-odir" , arg buildPath
, arg "-stubdir" , arg buildPath , arg "-stubdir" , arg buildPath
, arg "-hidir" , arg buildPath , arg "-hidir" , arg buildPath
, arg "-dep-makefile", arg $ buildPath -/- "haskell.deps" , arg "-dep-makefile", arg file
, append . concatMap (\way -> ["-dep-suffix", wayPrefix way]) $ ways , append . concatMap (\way -> ["-dep-suffix", wayPrefix way]) $ ways
, arg "-no-user-package-db" -- TODO: is this needed? , arg "-no-user-package-db" -- TODO: is this needed?
, arg "-rtsopts" -- TODO: is this needed? , arg "-rtsopts" -- TODO: is this needed?
, append hsSrcs ] , append srcs ]
-- TODO: do '-ticky' in all debug ways? -- TODO: do '-ticky' in all debug ways?
wayHcArgs :: Args wayHcArgs :: Args
......
...@@ -8,8 +8,8 @@ import Settings.Util ...@@ -8,8 +8,8 @@ import Settings.Util
ldArgs :: Args ldArgs :: Args
ldArgs = builder Ld ? do ldArgs = builder Ld ? do
stage <- getStage stage <- getStage
objs <- getDependencies
file <- getFile file <- getFile
objs <- getSources
confArgs <- getSettingList $ ConfLdLinkerArgs stage confArgs <- getSettingList $ ConfLdLinkerArgs stage
mconcat [ append confArgs mconcat [ append confArgs
, arg "-r" , arg "-r"
......
...@@ -13,18 +13,18 @@ import GHC.Generics ...@@ -13,18 +13,18 @@ import GHC.Generics
-- Target captures all parameters relevant to the current build target: -- Target captures all parameters relevant to the current build target:
-- * Stage and Package being built, -- * Stage and Package being built,
-- * dependencies (e.g., source files) that need to be tracked,
-- * Builder to be invoked, -- * Builder to be invoked,
-- * Way to be built (set to vanilla for most targets), -- * Way to be built (set to vanilla for most targets),
-- * source file(s) to be passed to Builder,
-- * file(s) to be produced. -- * file(s) to be produced.
data Target = Target data Target = Target
{ {
stage :: Stage, stage :: Stage,
package :: Package, package :: Package,
dependencies :: [FilePath], builder :: Builder,
builder :: Builder, way :: Way,
way :: Way, sources :: [FilePath],
files :: [FilePath] files :: [FilePath]
} }
deriving (Show, Eq, Generic) deriving (Show, Eq, Generic)
...@@ -35,12 +35,12 @@ type StageTarget = Target ...@@ -35,12 +35,12 @@ type StageTarget = Target
stageTarget :: Stage -> StageTarget stageTarget :: Stage -> StageTarget
stageTarget s = Target stageTarget s = Target
{ {
stage = s, stage = s,
package = error "stageTarget: package not set", package = error "stageTarget: package not set",
dependencies = error "stageTarget: dependencies not set", builder = error "stageTarget: builder not set",
builder = error "stageTarget: builder not set", way = vanilla,
way = vanilla, sources = error "stageTarget: sources not set",
files = error "stageTarget: files not set" files = error "stageTarget: files not set"
} }
-- StagePackageTarget is a partially constructed Target. Only stage and package -- StagePackageTarget is a partially constructed Target. Only stage and package
...@@ -50,36 +50,35 @@ type StagePackageTarget = Target ...@@ -50,36 +50,35 @@ type StagePackageTarget = Target
stagePackageTarget :: Stage -> Package -> StagePackageTarget stagePackageTarget :: Stage -> Package -> StagePackageTarget
stagePackageTarget s p = Target stagePackageTarget s p = Target
{ {
stage = s, stage = s,
package = p, package = p,
dependencies = error "stagePackageTarget: dependencies not set", builder = error "stagePackageTarget: builder not set",
builder = error "stagePackageTarget: builder not set", way = vanilla,
way = vanilla, sources = error "stagePackageTarget: sources not set",
files = error "stagePackageTarget: files not set" files = error "stagePackageTarget: files not set"
} }
-- FullTarget is a Target whose fields are all assigned -- FullTarget is a Target whose fields are all assigned
type FullTarget = Target type FullTarget = Target
-- Most targets are built only one way, vanilla, hence we set it by default. -- Most targets are built only one way, vanilla, hence we set it by default.
fullTarget :: StagePackageTarget -> [FilePath] -> Builder -> [FilePath] -> FullTarget fullTarget :: StagePackageTarget -> Builder -> [FilePath] -> [FilePath] -> FullTarget
fullTarget target deps b fs = target fullTarget target b srcs fs = target
{ {
dependencies = deps, builder = b,
builder = b, way = vanilla,
way = vanilla, sources = srcs,
files = fs files = fs
} }
-- Use this function to be explicit about the build way. -- Use this function to be explicit about the build way.
fullTargetWithWay :: StagePackageTarget -> [FilePath] -> Builder -> Way fullTargetWithWay :: StagePackageTarget -> Builder -> Way -> [FilePath] -> [FilePath] -> FullTarget
-> [FilePath] -> FullTarget fullTargetWithWay target b w srcs fs = target
fullTargetWithWay target deps b w fs = target
{ {
dependencies = deps, builder = b,
builder = b, way = w,
way = w, sources = srcs,
files = fs files = fs
} }
-- Instances for storing in the Shake database -- Instances for storing in the Shake database
......
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