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

Add support to multiple files in Target, implement registerPackage predicate.

parent 37262111
...@@ -140,7 +140,7 @@ builder :: Builder -> Predicate ...@@ -140,7 +140,7 @@ builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder) builder b = liftM (b ==) (asks getBuilder)
file :: FilePattern -> Predicate file :: FilePattern -> Predicate
file f = liftM (f ?==) (asks getFile) file f = liftM (any (f ?==)) (asks getFiles)
way :: Way -> Predicate way :: Way -> Predicate
way w = liftM (w ==) (asks getWay) way w = liftM (w ==) (asks getWay)
......
module Rules.Actions ( module Rules.Actions (
build, run, verboseRun, build, buildWhen, run, verboseRun,
) where ) where
import Base import Base
...@@ -21,6 +21,11 @@ build target = do ...@@ -21,6 +21,11 @@ build target = do
argsHash <- askArgsHash target argsHash <- askArgsHash target
run (getBuilder target) argList run (getBuilder target) argList
buildWhen :: Predicate -> FullTarget -> Action ()
buildWhen predicate target = do
bool <- interpretExpr target predicate
when bool $ build target
-- Run the builder with a given collection of arguments -- Run the builder with a given collection of arguments
verboseRun :: Builder -> [String] -> Action () verboseRun :: Builder -> [String] -> Action ()
verboseRun builder args = do verboseRun builder args = do
......
...@@ -4,10 +4,10 @@ module Rules.Data ( ...@@ -4,10 +4,10 @@ module Rules.Data (
cabalArgs, ghcPkgArgs, buildPackageData cabalArgs, ghcPkgArgs, buildPackageData
) where ) where
import Way
import Base import Base
import Package import Package
import Builder import Builder
import Switches
import Expression import Expression
import Control.Monad.Extra import Control.Monad.Extra
import Settings.GhcPkg import Settings.GhcPkg
...@@ -31,16 +31,14 @@ buildPackageData target = ...@@ -31,16 +31,14 @@ buildPackageData target =
, "build" </> "autogen" </> "cabal_macros.h" , "build" </> "autogen" </> "cabal_macros.h"
-- 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"
] &%> \_ -> do ] &%> \files -> do
let configure = pkgPath pkg </> "configure" let configure = pkgPath pkg </> "configure"
-- GhcCabal will 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] 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]
-- TODO: 1) automate? 2) mutliple files 3) vanilla? build $ fullTarget target files GhcCabal
build $ fullTarget target (path </> "package-data.mk") GhcCabal vanilla buildWhen registerPackage $ fullTarget target files (GhcPkg stage)
-- TODO: when (registerPackage settings) $
build $ fullTarget target (path </> "package-data.mk") (GhcPkg stage) vanilla
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:
......
...@@ -5,7 +5,8 @@ module Switches ( ...@@ -5,7 +5,8 @@ module Switches (
targetOss, targetOs, notTargetOs, targetOss, targetOs, notTargetOs,
targetArchs, dynamicGhcPrograms, ghcWithInterpreter, targetArchs, dynamicGhcPrograms, ghcWithInterpreter,
platformSupportsSharedLibs, crossCompiling, platformSupportsSharedLibs, crossCompiling,
gccIsClang, gccLt46, windowsHost, notWindowsHost gccIsClang, gccLt46, windowsHost, notWindowsHost,
registerPackage
) where ) where
import Base import Base
...@@ -91,6 +92,10 @@ windowsHost = configKeyValues "host-os-cpp" ["mingw32", "cygwin32"] ...@@ -91,6 +92,10 @@ windowsHost = configKeyValues "host-os-cpp" ["mingw32", "cygwin32"]
notWindowsHost :: Predicate notWindowsHost :: Predicate
notWindowsHost = liftM not windowsHost notWindowsHost = liftM not windowsHost
-- TODO: Actually, we don't register compiler in some circumstances -- fix.
registerPackage :: Predicate
registerPackage = return True
-- splitObjects :: Stage -> Condition -- splitObjects :: Stage -> Condition
-- splitObjects stage = do -- splitObjects stage = do
-- arch <- showArg TargetArch -- arch <- showArg TargetArch
......
{-# LANGUAGE DeriveGeneric, TypeSynonymInstances #-} {-# LANGUAGE DeriveGeneric, TypeSynonymInstances #-}
module Target ( module Target (
Target (..), StageTarget (..), StagePackageTarget (..), FullTarget (..), Target (..), StageTarget (..), StagePackageTarget (..), FullTarget (..),
stageTarget, stagePackageTarget, fullTarget stageTarget, stagePackageTarget, fullTarget, fullTargetWithWay
) where ) where
import Way import Way
...@@ -18,7 +18,7 @@ data Target = Target ...@@ -18,7 +18,7 @@ data Target = Target
{ {
getStage :: Stage, getStage :: Stage,
getPackage :: Package, getPackage :: Package,
getFile :: FilePath, -- TODO: handle multple files? getFiles :: [FilePath],
getBuilder :: Builder, getBuilder :: Builder,
getWay :: Way getWay :: Way
} }
...@@ -32,9 +32,9 @@ stageTarget stage = Target ...@@ -32,9 +32,9 @@ stageTarget stage = Target
{ {
getStage = stage, getStage = stage,
getPackage = error "stageTarget: Package not set", getPackage = error "stageTarget: Package not set",
getFile = error "stageTarget: File not set", getFiles = error "stageTarget: Files not set",
getBuilder = error "stageTarget: Builder not set", getBuilder = error "stageTarget: Builder not set",
getWay = error "stageTarget: Way not set" getWay = vanilla -- most targets are built only one way (vanilla)
} }
-- StagePackageTarget is a Target whose fields getStage and getPackage are -- StagePackageTarget is a Target whose fields getStage and getPackage are
...@@ -46,18 +46,28 @@ stagePackageTarget stage package = Target ...@@ -46,18 +46,28 @@ stagePackageTarget stage package = Target
{ {
getStage = stage, getStage = stage,
getPackage = package, getPackage = package,
getFile = error "stagePackageTarget: File not set", getFiles = error "stagePackageTarget: Files not set",
getBuilder = error "stagePackageTarget: Builder not set", getBuilder = error "stagePackageTarget: Builder not set",
getWay = error "stagePackageTarget: Way not set" getWay = vanilla
} }
-- FullTarget is a Target whose fields are all assigned -- FullTarget is a Target whose fields are all assigned
type FullTarget = Target type FullTarget = Target
fullTarget :: StagePackageTarget -> FilePath -> Builder -> Way -> FullTarget -- Most targets are built only one way, vanilla, hence we set it by default.
fullTarget target file builder way = target fullTarget :: StagePackageTarget -> [FilePath] -> Builder -> FullTarget
fullTarget target files builder = target
{ {
getFile = file, getFiles = files,
getBuilder = builder,
getWay = vanilla
}
-- Use this function to be explicit about build the way.
fullTargetWithWay :: StagePackageTarget -> [FilePath] -> Builder -> Way -> FullTarget
fullTargetWithWay target files builder way = target
{
getFiles = files,
getBuilder = builder, getBuilder = builder,
getWay = way getWay = way
} }
...@@ -65,7 +75,7 @@ fullTarget target file builder way = target ...@@ -65,7 +75,7 @@ fullTarget target file builder way = target
-- Shows a (full) target as "package:file@stage (builder, way)" -- Shows a (full) target as "package:file@stage (builder, way)"
instance Show FullTarget where instance Show FullTarget where
show target = show (getPackage target) show target = show (getPackage target)
++ ":" ++ getFile target ++ ":" ++ show (getFiles target)
++ "@" ++ show (getStage target) ++ "@" ++ show (getStage target)
++ " (" ++ show (getBuilder target) ++ " (" ++ show (getBuilder target)
++ ", " ++ show (getWay target) ++ ")" ++ ", " ++ show (getWay target) ++ ")"
......
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