Commit 4f2fbbbe authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add dependencies to Target.

parent 28a80787
...@@ -9,7 +9,8 @@ module Expression ( ...@@ -9,7 +9,8 @@ module Expression (
apply, append, appendM, remove, apply, append, appendM, remove,
appendSub, appendSubD, filterSub, removeSub, appendSub, appendSubD, filterSub, removeSub,
interpret, interpretExpr, interpret, interpretExpr,
getStage, getPackage, getBuilder, getFiles, getFile, getWay, getStage, getPackage, getBuilder, getFiles, getFile,
getDependencies, getDependency, getWay,
stage, package, builder, stagedBuilder, file, way stage, package, builder, stagedBuilder, file, way
) where ) where
...@@ -173,6 +174,18 @@ getFile = do ...@@ -173,6 +174,18 @@ 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 :: Expr Way
getWay = asks Target.way getWay = asks Target.way
......
...@@ -16,6 +16,7 @@ import Development.Shake ...@@ -16,6 +16,7 @@ import Development.Shake
-- the build system). -- the build system).
build :: FullTarget -> Action () build :: FullTarget -> Action ()
build target = do build target = do
need $ Target.dependencies target
argList <- interpret target args argList <- interpret target args
-- The line below forces the rule to be rerun if the args hash has changed -- The line below forces the rule to be rerun if the args hash has changed
argsHash <- askArgsHash target argsHash <- askArgsHash target
......
...@@ -15,9 +15,11 @@ import Development.Shake ...@@ -15,9 +15,11 @@ import Development.Shake
-- Build package-data.mk by using GhcCabal to process pkgCabal file -- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData :: StagePackageTarget -> Rules () buildPackageData :: StagePackageTarget -> Rules ()
buildPackageData target = buildPackageData target =
let stage = Target.stage target let stage = Target.stage target
pkg = Target.package target pkg = Target.package target
path = targetPath stage pkg path = targetPath stage pkg
cabal = pkgPath pkg -/- pkgCabal pkg
configure = pkgPath pkg -/- "configure"
in in
(path -/-) <$> (path -/-) <$>
[ "package-data.mk" [ "package-data.mk"
...@@ -28,13 +30,12 @@ buildPackageData target = ...@@ -28,13 +30,12 @@ buildPackageData target =
-- TODO: Is this needed? Also check out Paths_cpsa.hs. -- TODO: Is this needed? Also check out Paths_cpsa.hs.
-- , "build" -/- "autogen" -/- ("Paths_" ++ name) <.> "hs" -- , "build" -/- "autogen" -/- ("Paths_" ++ name) <.> "hs"
] &%> \files -> do ] &%> \files -> do
let configure = pkgPath pkg -/- "configure" -- GhcCabal may run the configure script, so we depend on it
-- GhcCabal will run the configure script, so we depend on it
need [pkgPath pkg -/- pkgCabal pkg]
-- We still don't know who built the configure script from configure.ac -- We still don't know who built the configure script from configure.ac
whenM (doesFileExist $ configure <.> "ac") $ need [configure] whenM (doesFileExist $ configure <.> "ac") $ need [configure]
build $ fullTarget target files GhcCabal build $ fullTarget target [cabal] GhcCabal files
buildWhen registerPackage $ fullTarget target files (GhcPkg stage) buildWhen registerPackage $
fullTarget target [cabal] (GhcPkg stage) files
postProcessPackageData $ path -/- "package-data.mk" postProcessPackageData $ path -/- "package-data.mk"
-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile: -- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
......
...@@ -6,6 +6,7 @@ import Package ...@@ -6,6 +6,7 @@ import Package
import Expression import Expression
import qualified Target import qualified Target
import Oracles.PackageData import Oracles.PackageData
import Settings.Util
import Settings.TargetDirectory import Settings.TargetDirectory
import Rules.Actions import Rules.Actions
import Development.Shake import Development.Shake
...@@ -17,13 +18,16 @@ buildPackageDependencies target = ...@@ -17,13 +18,16 @@ buildPackageDependencies target =
path = targetPath stage pkg path = targetPath stage pkg
buildPath = path -/- "build" buildPath = path -/- "build"
in do in do
(buildPath -/- "haskell.deps") %> \file -> (buildPath -/- "haskell.deps") %> \file -> do
build $ fullTarget target [file] (GhcM stage) srcs <- interpretExpr target getHsSources
build $ fullTarget target srcs (GhcM stage) [file]
(buildPath -/- "c.deps") %> \file -> do (buildPath -/- "c.deps") %> \file -> do
srcs <- pkgDataList $ CSrcs path srcs <- pkgDataList $ CSrcs path
deps <- fmap concat $ forM srcs $ \src -> do deps <- forM srcs $ \src -> do
build $ fullTarget target [pkgPath pkg -/- src] (GccM stage) let srcFile = pkgPath pkg -/- src
liftIO $ readFile (buildPath -/- takeFileName src <.> "deps") depFile = buildPath -/- takeFileName src <.> "deps"
writeFileChanged file deps build $ fullTarget target [srcFile] (GccM stage) [depFile]
liftIO $ removeFiles path ["*.c.deps"] liftIO . readFile $ depFile
writeFileChanged file (concat deps)
liftIO $ removeFiles buildPath ["*.c.deps"]
...@@ -11,6 +11,7 @@ gccMArgs :: Args ...@@ -11,6 +11,7 @@ gccMArgs :: Args
gccMArgs = stagedBuilder GccM ? do gccMArgs = stagedBuilder GccM ? do
path <- getTargetPath path <- getTargetPath
file <- getFile file <- getFile
src <- getDependency
ccArgs <- getPkgDataList CcArgs ccArgs <- getPkgDataList CcArgs
mconcat mconcat
[ arg "-E" [ arg "-E"
...@@ -18,10 +19,10 @@ gccMArgs = stagedBuilder GccM ? do ...@@ -18,10 +19,10 @@ gccMArgs = stagedBuilder GccM ? do
, append ccArgs -- TODO: remove? any other flags? , append ccArgs -- TODO: remove? any other flags?
, includeGccArgs , includeGccArgs
, arg "-MF" , arg "-MF"
, arg $ path -/- "build" -/- takeFileName file <.> "deps" , arg file
, arg "-x" , arg "-x"
, arg "c" , arg "c"
, arg file ] , arg src ]
includeGccArgs :: Args includeGccArgs :: Args
includeGccArgs = do includeGccArgs = do
......
...@@ -88,6 +88,7 @@ bootPackageDbArgs = do ...@@ -88,6 +88,7 @@ bootPackageDbArgs = do
-- This is a positional argument, hence: -- This is a positional argument, hence:
-- * if it is empty, we need to emit one empty string argument; -- * if it is empty, we need to emit one empty string argument;
-- * otherwise, we must collapse it into one space-separated string. -- * otherwise, we must collapse it into one space-separated string.
-- TODO: should be non-empty for compiler
dllArgs :: Args dllArgs :: Args
dllArgs = arg "" dllArgs = arg ""
......
...@@ -10,7 +10,6 @@ import Oracles.Flag ...@@ -10,7 +10,6 @@ import Oracles.Flag
import Oracles.PackageData import Oracles.PackageData
import Settings.Util import Settings.Util
import Settings.Ways import Settings.Ways
import Development.Shake
ghcMArgs :: Args ghcMArgs :: Args
ghcMArgs = stagedBuilder GhcM ? do ghcMArgs = stagedBuilder GhcM ? do
...@@ -69,21 +68,3 @@ includeGhcArgs = do ...@@ -69,21 +68,3 @@ includeGhcArgs = do
, append . map (\dir -> "-I" ++ pkgPath -/- dir) $ incDirs , append . map (\dir -> "-I" ++ pkgPath -/- dir) $ incDirs
, arg "-optP-include" -- TODO: Shall we also add -cpp? , arg "-optP-include" -- TODO: Shall we also add -cpp?
, arg $ "-optP" ++ autogenPath -/- "cabal_macros.h" ] , arg $ "-optP" ++ autogenPath -/- "cabal_macros.h" ]
getHsSources :: Expr [FilePath]
getHsSources = do
path <- getTargetPath
pkgPath <- getPackagePath
srcDirs <- getPkgDataList SrcDirs
let paths = (path -/- "build/autogen") : map (pkgPath -/-) srcDirs
getSourceFiles paths [".hs", ".lhs"]
-- Find all source files in specified paths and with given extensions
getSourceFiles :: [FilePath] -> [String] -> Expr [FilePath]
getSourceFiles paths exts = do
modules <- getPkgDataList Modules
let modPaths = map (replaceEq '.' '/') modules
candidates = [ p -/- m ++ e | p <- paths, m <- modPaths, e <- exts ]
files <- lift $ filterM (doesDirectoryExist . takeDirectory) candidates
result <- lift $ getDirectoryFiles "" files
return $ map unifyPath result
...@@ -5,6 +5,7 @@ module Settings.Util ( ...@@ -5,6 +5,7 @@ module Settings.Util (
getFlag, getSetting, getSettingList, getFlag, getSetting, getSettingList,
getPkgData, getPkgDataList, getPkgData, getPkgDataList,
getPackagePath, getTargetPath, getTargetDirectory, getPackagePath, getTargetPath, getTargetDirectory,
getHsSources, getSourceFiles,
appendCcArgs, appendCcArgs,
needBuilder needBuilder
-- argBuilderPath, argStagedBuilderPath, -- argBuilderPath, argStagedBuilderPath,
...@@ -15,6 +16,7 @@ module Settings.Util ( ...@@ -15,6 +16,7 @@ module Settings.Util (
-- argPackageConstraints, -- argPackageConstraints,
) where ) where
import Util
import Builder import Builder
import Package import Package
import Expression import Expression
...@@ -68,6 +70,25 @@ getTargetPath = liftM2 targetPath getStage getPackage ...@@ -68,6 +70,25 @@ getTargetPath = liftM2 targetPath getStage getPackage
getTargetDirectory :: Expr FilePath getTargetDirectory :: Expr FilePath
getTargetDirectory = liftM2 targetDirectory getStage getPackage getTargetDirectory = liftM2 targetDirectory getStage getPackage
-- Find all Haskell source files for the current target
getHsSources :: Expr [FilePath]
getHsSources = do
path <- getTargetPath
pkgPath <- getPackagePath
srcDirs <- getPkgDataList SrcDirs
let paths = (path -/- "build/autogen") : map (pkgPath -/-) srcDirs
getSourceFiles paths [".hs", ".lhs"]
-- Find all source files in specified paths and with given extensions
getSourceFiles :: [FilePath] -> [String] -> Expr [FilePath]
getSourceFiles paths exts = do
modules <- getPkgDataList Modules
let modPaths = map (replaceEq '.' '/') modules
candidates = [ p -/- m ++ e | p <- paths, m <- modPaths, e <- exts ]
files <- lift $ filterM (doesDirectoryExist . takeDirectory) candidates
result <- lift $ getDirectoryFiles "" files
return $ map unifyPath result
-- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal -- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
appendCcArgs :: [String] -> Args appendCcArgs :: [String] -> Args
appendCcArgs xs = do appendCcArgs xs = do
......
{-# LANGUAGE DeriveGeneric, TypeSynonymInstances #-} {-# LANGUAGE DeriveGeneric, TypeSynonymInstances #-}
module Target ( module Target (
Target (..), StageTarget (..), StagePackageTarget (..), FullTarget (..), Target (..), StageTarget (..), StagePackageTarget (..), FullTarget (..),
stageTarget, stagePackageTarget, fullTarget, fullTarwithWay stageTarget, stagePackageTarget, fullTarget, fullTargetWithWay
) where ) where
import Way import Way
...@@ -11,18 +11,22 @@ import Builder ...@@ -11,18 +11,22 @@ import Builder
import GHC.Generics import GHC.Generics
import Development.Shake.Classes import Development.Shake.Classes
-- Target captures parameters relevant to the current build target: Stage and -- Target captures all parameters relevant to the current build target:
-- Package being built, Builder that is to be invoked, file(s) that are to -- * Stage and Package being built,
-- be built and the Way they are to be built. -- * dependencies (e.g., source files) that need to be tracked,
-- * Builder to be invoked,
-- * Way to be built (set to vanilla for most targets),
-- * file(s) to be produced.
data Target = Target data Target = Target
{ {
stage :: Stage, stage :: Stage,
package :: Package, package :: Package,
files :: [FilePath], dependencies :: [FilePath],
builder :: Builder, builder :: Builder,
way :: Way way :: Way,
files :: [FilePath]
} }
deriving (Eq, Generic) deriving (Show, Eq, Generic)
-- StageTarget is a partially constructed Target. Only stage is guaranteed to -- StageTarget is a partially constructed Target. Only stage is guaranteed to
-- be assigned. -- be assigned.
...@@ -31,11 +35,12 @@ type StageTarget = Target ...@@ -31,11 +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",
files = error "stageTarget: Files not set", dependencies = error "stageTarget: dependencies not set",
builder = error "stageTarget: Builder not set", builder = error "stageTarget: builder not set",
way = vanilla way = vanilla,
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
...@@ -45,42 +50,37 @@ type StagePackageTarget = Target ...@@ -45,42 +50,37 @@ 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,
files = error "stagePackageTarget: Files not set", dependencies = error "stagePackageTarget: dependencies not set",
builder = error "stagePackageTarget: Builder not set", builder = error "stagePackageTarget: builder not set",
way = vanilla way = vanilla,
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 -> FullTarget fullTarget :: StagePackageTarget -> [FilePath] -> Builder -> [FilePath] -> FullTarget
fullTarget target fs b = target fullTarget target deps b fs = target
{ {
files = fs, dependencies = deps,
builder = b, builder = b,
way = vanilla way = vanilla,
files = fs
} }
-- Use this function to be explicit about the build way. -- Use this function to be explicit about the build way.
fullTarwithWay :: StagePackageTarget -> [FilePath] -> Builder -> Way -> FullTarget fullTargetWithWay :: StagePackageTarget -> [FilePath] -> Builder -> Way -> [FilePath] -> FullTarget
fullTarwithWay target fs b w = target fullTargetWithWay target deps b w fs = target
{ {
files = fs, dependencies = deps,
builder = b, builder = b,
way = w way = w,
files = fs
} }
-- Shows a (full) target as "package:file@stage (builder, way)"
instance Show FullTarget where
show target = show (package target)
++ ":" ++ show (files target)
++ "@" ++ show (stage target)
++ " (" ++ show (builder target)
++ ", " ++ show (way target) ++ ")"
-- Instances for storing in the Shake database -- Instances for storing in the Shake database
instance Binary FullTarget instance Binary FullTarget
instance NFData FullTarget instance NFData FullTarget
......
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