[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:56:17 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