[commit: ghc] wip/nfs-locking: Add a draft implementation for resolution of Config variables. (489e385)
git at git.haskell.org
git at git.haskell.org
Thu Oct 26 23:27:10 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nfs-locking
Link : http://ghc.haskell.org/trac/ghc/changeset/489e385ab98b0ce8ec0b9ab8248b9bc9adb1f38b/ghc
>---------------------------------------------------------------
commit 489e385ab98b0ce8ec0b9ab8248b9bc9adb1f38b
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date: Fri Apr 17 22:49:20 2015 +0100
Add a draft implementation for resolution of Config variables.
>---------------------------------------------------------------
489e385ab98b0ce8ec0b9ab8248b9bc9adb1f38b
src/Expression/Base.hs | 24 +++++++++----------
src/Expression/Build.hs | 2 +-
src/Expression/Resolve.hs | 60 +++++++++++++++++++++++++++++++++++++++++++++++
src/Main.hs | 40 +++++++++++++++++++++++++++++--
src/Targets.hs | 2 +-
5 files changed, 112 insertions(+), 16 deletions(-)
diff --git a/src/Expression/Base.hs b/src/Expression/Base.hs
index e9316e8..ef6ad72 100644
--- a/src/Expression/Base.hs
+++ b/src/Expression/Base.hs
@@ -118,7 +118,6 @@ argWithStagedBuilder :: (Stage -> Builder) -> Settings
argWithStagedBuilder f =
msum $ map (\s -> stage s ? argWithBuilder (f s)) [Stage0 ..]
-
-- Accessing key value pairs from package-data.mk files
argPackageKey :: Settings
argPackageKey = return $ PackageData "PACKAGE_KEY"
@@ -165,35 +164,36 @@ argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
argPrefixPath :: String -> Settings -> Settings
argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
--- Partially evaluate Settings using a truth-teller (compute a 'projection')
-project :: (BuildVariable -> Maybe Bool) -> Settings -> Settings
+-- Partially evaluate expression using a truth-teller (compute a 'projection')
+project :: (BuildVariable -> Maybe Bool) -> BuildExpression v
+ -> BuildExpression v
project _ Epsilon = Epsilon
project t (Vertex v) = Vertex v -- TODO: go deeper
project t (Overlay l r) = Overlay (project t l) (project t r)
project t (Sequence l r) = Sequence (project t l) (project t r)
project t (Condition l r) = Condition (evaluate t l) (project t r)
--- Partial evaluation of settings
-
-setPackage :: Package -> Settings -> Settings
+-- Partial evaluation of setting
+setPackage :: Package -> BuildExpression v -> BuildExpression v
setPackage = project . matchPackage
-setBuilder :: Builder -> Settings -> Settings
+setBuilder :: Builder -> BuildExpression v -> BuildExpression v
setBuilder = project . matchBuilder
-setBuilderFamily :: (Stage -> Builder) -> Settings -> Settings
+setBuilderFamily :: (Stage -> Builder) -> BuildExpression v
+ -> BuildExpression v
setBuilderFamily = project . matchBuilderFamily
-setStage :: Stage -> Settings -> Settings
+setStage :: Stage -> BuildExpression v -> BuildExpression v
setStage = project . matchStage
-setWay :: Way -> Settings -> Settings
+setWay :: Way -> BuildExpression v -> BuildExpression v
setWay = project . matchWay
-setFile :: FilePath -> Settings -> Settings
+setFile :: FilePath -> BuildExpression v -> BuildExpression v
setFile = project . matchFile
-setConfig :: String -> String -> Settings -> Settings
+setConfig :: String -> String -> BuildExpression v -> BuildExpression v
setConfig key = project . matchConfig key
--type ArgsTeller = Args -> Maybe [String]
diff --git a/src/Expression/Build.hs b/src/Expression/Build.hs
index 19ff60e..8a7372d 100644
--- a/src/Expression/Build.hs
+++ b/src/Expression/Build.hs
@@ -21,8 +21,8 @@ module Expression.Build (
import Control.Applicative
import Base
import Ways
-import Package (Package)
import Oracles.Builder
+import Package (Package)
import Expression.PG
-- Build variables that can be used in build predicates
diff --git a/src/Expression/Resolve.hs b/src/Expression/Resolve.hs
new file mode 100644
index 0000000..4ce4f7b
--- /dev/null
+++ b/src/Expression/Resolve.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Expression.Resolve (
+ ResolveConfig (..)
+ ) where
+
+import Base
+import Oracles.Base
+import Expression.PG
+import Expression.Predicate
+import Expression.Base
+import Expression.Build
+
+-- Resolve configuration variables
+class ResolveConfig a where
+ resolveConfig :: a -> Action a
+ -- resolveConfig = return . id
+
+instance ResolveConfig BuildPredicate where
+ resolveConfig p @ (Evaluated _) = return p
+
+ resolveConfig (Unevaluated (ConfigVariable key value)) = do
+ lookup <- askConfig key
+ return $ Evaluated $ lookup == value
+
+ resolveConfig p @ (Unevaluated _) = return p
+
+ resolveConfig (Not p) = do
+ p' <- resolveConfig p
+ return $ Not p'
+
+ resolveConfig (And p q) = do
+ p' <- resolveConfig p
+ q' <- resolveConfig q
+ return $ And p' q'
+
+ resolveConfig (Or p q) = do
+ p' <- resolveConfig p
+ q' <- resolveConfig q
+ return $ Or p' q'
+
+instance ResolveConfig (BuildExpression v) where
+ resolveConfig Epsilon = return Epsilon
+
+ resolveConfig v @ (Vertex _) = return v -- TODO: go deeper
+
+ resolveConfig (Overlay l r) = do
+ l' <- resolveConfig l
+ r' <- resolveConfig r
+ return $ Overlay l' r'
+
+ resolveConfig (Sequence l r) = do
+ l' <- resolveConfig l
+ r' <- resolveConfig r
+ return $ Sequence l' r'
+
+ resolveConfig (Condition l r) = do
+ l' <- resolveConfig l
+ r' <- resolveConfig r
+ return $ Condition l' r'
diff --git a/src/Main.hs b/src/Main.hs
index 4b6349a..bf0e8f7 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,7 +4,9 @@ import Oracles
import Package
import Targets
import Settings
+import Expression.Base
import Expression.Simplify
+import Expression.Resolve
main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do
oracleRules
@@ -13,6 +15,40 @@ main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do
--packageRules
action $ do
- putNormal $ "targetPackages = " ++ show (simplify targetPackages)
- putNormal $ "\ntargetWays = " ++ show (simplify targetWays)
+ putNormal $ "\ntargetPackages = " ++ show (simplify targetPackages)
+ putNormal $ "\n\ntargetWays = " ++ show (simplify targetWays)
+ putNormal $ "\n\n=============================\n"
+ -- Read config file
+ targetPackages' <- resolveConfig targetPackages
+ targetWays' <- resolveConfig targetWays
+
+ -- Build stages
+ forM_ [Stage0 ..] $ \stage -> do
+ putNormal $ "Stage = " ++ show stage
+ let packages = setStage stage targetPackages'
+ ways = setStage stage targetWays'
+ putNormal $ "\n packages = " ++ show (simplify packages)
+ putNormal $ "\n ways = " ++ show (simplify ways)
+
+ --forM_ targetPackages $ \pkg @ (Package name path _ todo) -> do
+ -- forM_ todo $ \todoItem @ (stage, dist, settings) -> do
+
+ -- -- Want top .o and .a files for the pkg/todo combo
+ -- -- We build *only one* vanilla .o file (not sure why)
+ -- -- We build .way_a file for each way (or its dynamic version).
+ -- -- TODO: Check BUILD_GHCI_LIB flag to decide if .o is needed
+ -- -- TODO: move this into a separate file (perhaps, to Targets.hs?)
+ -- action $ when (buildWhen settings) $ do
+ -- let pathDist = path </> dist
+ -- buildDir = pathDist </> "build"
+ -- key <- showArg (PackageKey pathDist)
+ -- let oFile = buildDir </> "Hs" ++ key <.> "o"
+ -- ways' <- ways settings
+ -- libFiles <- forM ways' $ \way -> do
+ -- extension <- libsuf way
+ -- return $ buildDir </> "libHs" ++ key <.> extension
+ -- need $ [oFile] ++ libFiles
+
+ -- -- Build rules for the package
+ -- buildPackage pkg todoItem
diff --git a/src/Targets.hs b/src/Targets.hs
index 1b7bba2..bc2756a 100644
--- a/src/Targets.hs
+++ b/src/Targets.hs
@@ -26,7 +26,7 @@ targetPackages = msum
packagesStage0 :: Packages
packagesStage0 = msum
[ fromList [ binPackageDb, binary, cabal, hoopl, hpc, transformers ]
- , windowsHost && not (targetOs "ios") ? return terminfo ]
+ , not windowsHost && not (targetOs "ios") ? return terminfo ]
packagesStage1 :: Packages
packagesStage1 = msum
More information about the ghc-commits
mailing list