[commit: ghc] wip/nfs-locking: Add support to multiple files in Target, implement registerPackage predicate. (c41e156)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/c41e156c6bee670112d50825040ccc2ebc56a78e/ghc

>---------------------------------------------------------------

commit c41e156c6bee670112d50825040ccc2ebc56a78e
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Wed Jul 15 23:44:30 2015 +0200

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


>---------------------------------------------------------------

c41e156c6bee670112d50825040ccc2ebc56a78e
 src/Expression.hs    |  2 +-
 src/Rules/Actions.hs |  7 ++++++-
 src/Rules/Data.hs    | 10 ++++------
 src/Switches.hs      |  7 ++++++-
 src/Target.hs        | 30 ++++++++++++++++++++----------
 5 files changed, 37 insertions(+), 19 deletions(-)

diff --git a/src/Expression.hs b/src/Expression.hs
index 2f8ea4b..0ee8034 100644
--- a/src/Expression.hs
+++ b/src/Expression.hs
@@ -140,7 +140,7 @@ builder :: Builder -> Predicate
 builder b = liftM (b ==) (asks getBuilder)
 
 file :: FilePattern -> Predicate
-file f = liftM (f ?==) (asks getFile)
+file f = liftM (any (f ?==)) (asks getFiles)
 
 way :: Way -> Predicate
 way w = liftM (w ==) (asks getWay)
diff --git a/src/Rules/Actions.hs b/src/Rules/Actions.hs
index 9010647..d29d486 100644
--- a/src/Rules/Actions.hs
+++ b/src/Rules/Actions.hs
@@ -1,5 +1,5 @@
 module Rules.Actions (
-    build, run, verboseRun,
+    build, buildWhen, run, verboseRun,
     ) where
 
 import Base
@@ -21,6 +21,11 @@ build target = do
     argsHash <- askArgsHash target
     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
 verboseRun :: Builder -> [String] -> Action ()
 verboseRun builder args = do
diff --git a/src/Rules/Data.hs b/src/Rules/Data.hs
index beadd7e..eb34b65 100644
--- a/src/Rules/Data.hs
+++ b/src/Rules/Data.hs
@@ -4,10 +4,10 @@ module Rules.Data (
     cabalArgs, ghcPkgArgs, buildPackageData
     ) where
 
-import Way
 import Base
 import Package
 import Builder
+import Switches
 import Expression
 import Control.Monad.Extra
 import Settings.GhcPkg
@@ -31,16 +31,14 @@ buildPackageData target =
     , "build" </> "autogen" </> "cabal_macros.h"
     -- TODO: Is this needed? Also check out Paths_cpsa.hs.
     -- , "build" </> "autogen" </> ("Paths_" ++ name) <.> "hs"
-    ] &%> \_ -> do
+    ] &%> \files -> do
         let configure = pkgPath pkg </> "configure"
         -- 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
         whenM (doesFileExist $ configure <.> "ac") $ need [configure]
-        -- TODO: 1) automate? 2) mutliple files 3) vanilla?
-        build $ fullTarget target (path </> "package-data.mk") GhcCabal vanilla
-        -- TODO: when (registerPackage settings) $
-        build $ fullTarget target (path </> "package-data.mk") (GhcPkg stage) vanilla
+        build $ fullTarget target files GhcCabal
+        buildWhen registerPackage $ fullTarget target files (GhcPkg stage)
         postProcessPackageData $ path </> "package-data.mk"
 
 -- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
diff --git a/src/Switches.hs b/src/Switches.hs
index ce03ade..8ab2de2 100644
--- a/src/Switches.hs
+++ b/src/Switches.hs
@@ -5,7 +5,8 @@ module Switches (
     targetOss, targetOs, notTargetOs,
     targetArchs, dynamicGhcPrograms, ghcWithInterpreter,
     platformSupportsSharedLibs, crossCompiling,
-    gccIsClang, gccLt46, windowsHost, notWindowsHost
+    gccIsClang, gccLt46, windowsHost, notWindowsHost,
+    registerPackage
     ) where
 
 import Base
@@ -91,6 +92,10 @@ windowsHost = configKeyValues "host-os-cpp" ["mingw32", "cygwin32"]
 notWindowsHost :: Predicate
 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 = do
 --     arch <- showArg TargetArch
diff --git a/src/Target.hs b/src/Target.hs
index 198cffc..6b02af9 100644
--- a/src/Target.hs
+++ b/src/Target.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE DeriveGeneric, TypeSynonymInstances #-}
 module Target (
     Target (..), StageTarget (..), StagePackageTarget (..), FullTarget (..),
-    stageTarget, stagePackageTarget, fullTarget
+    stageTarget, stagePackageTarget, fullTarget, fullTargetWithWay
     ) where
 
 import Way
@@ -18,7 +18,7 @@ data Target = Target
      {
         getStage   :: Stage,
         getPackage :: Package,
-        getFile    :: FilePath, -- TODO: handle multple files?
+        getFiles   :: [FilePath],
         getBuilder :: Builder,
         getWay     :: Way
      }
@@ -32,9 +32,9 @@ stageTarget stage = Target
     {
         getStage   = stage,
         getPackage = error "stageTarget: Package not set",
-        getFile    = error "stageTarget: File not set",
+        getFiles   = error "stageTarget: Files 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
@@ -46,18 +46,28 @@ stagePackageTarget stage package = Target
     {
         getStage   = stage,
         getPackage = package,
-        getFile    = error "stagePackageTarget: File not set",
+        getFiles   = error "stagePackageTarget: Files 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
 type FullTarget = Target
 
-fullTarget :: StagePackageTarget -> FilePath -> Builder -> Way -> FullTarget
-fullTarget target file builder way = target
+-- Most targets are built only one way, vanilla, hence we set it by default.
+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,
         getWay     = way
     }
@@ -65,7 +75,7 @@ fullTarget target file builder way = target
 -- Shows a (full) target as "package:file at stage (builder, way)"
 instance Show FullTarget where
     show target = show (getPackage target)
-                  ++ ":" ++ getFile target
+                  ++ ":" ++ show (getFiles target)
                   ++ "@" ++ show (getStage target)
                   ++ " (" ++ show (getBuilder target)
                   ++ ", " ++ show (getWay target) ++ ")"