Replace Config oracle with generic key-value text file oracle
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Wed, 9 Aug 2017 22:39:23 +0000 (23:39 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Wed, 9 Aug 2017 22:39:23 +0000 (23:39 +0100)
See #347

hadrian.cabal
src/Hadrian/Oracles/Config.hs [deleted file]
src/Hadrian/Oracles/KeyValue.hs [new file with mode: 0644]
src/Oracles/Flag.hs
src/Oracles/ModuleFiles.hs
src/Oracles/PackageData.hs
src/Oracles/Setting.hs
src/Rules/Oracles.hs
src/Settings.hs

index 3df1b59..c39df50 100644 (file)
@@ -28,8 +28,8 @@ executable hadrian
                        , GHC
                        , Hadrian.Expression
                        , Hadrian.Oracles.ArgsHash
-                       , Hadrian.Oracles.Config
                        , Hadrian.Oracles.DirectoryContents
+                       , Hadrian.Oracles.KeyValue
                        , Hadrian.Oracles.Path
                        , Hadrian.Target
                        , Hadrian.Utilities
diff --git a/src/Hadrian/Oracles/Config.hs b/src/Hadrian/Oracles/Config.hs
deleted file mode 100644 (file)
index 1263f1a..0000000
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Hadrian.Oracles.Config (askConfig, unsafeAskConfig, configOracle) where
-
-import Control.Monad
-import qualified Data.HashMap.Strict as Map
-import Data.Maybe
-import Development.Shake
-import Development.Shake.Classes
-import Development.Shake.Config
-
-import Hadrian.Utilities
-
-newtype Config = Config String
-    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
-
--- | Lookup a configuration setting raising an error if the key is not found.
-unsafeAskConfig :: String -> Action String
-unsafeAskConfig key = (fromMaybe $ error msg) <$> askConfig key
-  where
-    msg = "Key " ++ quote key ++ " not found in configuration files."
-
--- | Lookup a configuration setting.
-askConfig :: String -> Action (Maybe String)
-askConfig = askOracle . Config
-
--- | This oracle reads and parses a configuration file consisting of key-value
--- pairs @key = value@ and answers 'askConfig' queries tracking the results.
-configOracle :: FilePath -> Rules ()
-configOracle configFile = void $ do
-    cfg <- newCache $ \() -> do
-        need [configFile]
-        putLoud $ "Reading " ++ configFile ++ "..."
-        liftIO $ readConfigFile configFile
-    addOracle $ \(Config key) -> Map.lookup key <$> cfg ()
diff --git a/src/Hadrian/Oracles/KeyValue.hs b/src/Hadrian/Oracles/KeyValue.hs
new file mode 100644 (file)
index 0000000..b58cfda
--- /dev/null
@@ -0,0 +1,42 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Hadrian.Oracles.KeyValue (
+    lookupValue, lookupValueOrEmpty, lookupValueOrError, keyValueOracle
+    ) where
+
+import Control.Monad
+import qualified Data.HashMap.Strict as Map
+import Data.Maybe
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.Config
+
+import Hadrian.Utilities
+
+newtype KeyValue = KeyValue (FilePath, String)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+
+-- | Lookup a value in a key-value text file, tracking the result.
+lookupValue :: FilePath -> String -> Action (Maybe String)
+lookupValue file key = askOracle $ KeyValue (file, key)
+
+-- | Lookup a value in a key-value text file, tracking the result. Return the
+-- empty string if the key is not found.
+lookupValueOrEmpty :: FilePath -> String -> Action String
+lookupValueOrEmpty file key = fromMaybe "" <$> askOracle (KeyValue (file, key))
+
+-- | Lookup a value in a key-value text file, tracking the result. Raise an
+-- error if the key is not found.
+lookupValueOrError :: FilePath -> String -> Action String
+lookupValueOrError file key = (fromMaybe $ error msg) <$> lookupValue file key
+  where
+    msg = "Key " ++ quote key ++ " not found in file " ++ quote file
+
+-- | This oracle reads and parses text files consisting of key-value pairs
+-- @key = value@ and answers 'lookupValue' queries tracking the results.
+keyValueOracle :: Rules ()
+keyValueOracle = void $ do
+    cache <- newCache $ \file -> do
+        need [file]
+        putLoud $ "Reading " ++ file ++ "..."
+        liftIO $ readConfigFile file
+    addOracle $ \(KeyValue (file, key)) -> Map.lookup key <$> cache file
index 59b6954..51f3e46 100644 (file)
@@ -3,7 +3,7 @@ module Oracles.Flag (
     ghcWithSMP, ghcWithNativeCodeGen, supportsSplitObjects
     ) where
 
-import Hadrian.Oracles.Config
+import Hadrian.Oracles.KeyValue
 
 import Base
 import Oracles.Setting
@@ -38,7 +38,7 @@ flag f = do
             SupportsThisUnitId -> "supports-this-unit-id"
             WithLibdw          -> "with-libdw"
             UseSystemFfi       -> "use-system-ffi"
-    value <- unsafeAskConfig key
+    value <- lookupValueOrError configFile key
     when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag "
         ++ quote (key ++ " = " ++ value) ++ "cannot be parsed."
     return $ value == "YES"
index 409a586..ebe3ab1 100644 (file)
@@ -12,7 +12,7 @@ import Expression
 import Oracles.PackageData
 import Settings.Path
 
-newtype ModuleFilesKey = ModuleFilesKey (Stage, Package)
+newtype ModuleFiles = ModuleFiles (Stage, Package)
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
 
 newtype Generator = Generator (Stage, Package, FilePath)
@@ -102,7 +102,7 @@ moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs"
 contextFiles :: Context -> Action [(String, Maybe FilePath)]
 contextFiles context@Context {..} = do
     modules <- fmap sort . pkgDataList . Modules $ buildPath context
-    zip modules <$> askOracle (ModuleFilesKey (stage, package))
+    zip modules <$> askOracle (ModuleFiles (stage, package))
 
 -- | This is an important oracle whose role is to find and cache module source
 -- files. It takes a 'Stage' and a 'Package', looks up corresponding source
@@ -117,7 +117,7 @@ contextFiles context@Context {..} = do
 -- Just "compiler/parser/Lexer.x"]. The oracle ignores @.(l)hs-boot@ files.
 moduleFilesOracle :: Rules ()
 moduleFilesOracle = void $ do
-    void . addOracle $ \(ModuleFilesKey (stage, package)) -> do
+    void . addOracle $ \(ModuleFiles (stage, package)) -> do
         let context = vanillaContext stage package
             path    = buildPath context
         srcDirs <-             pkgDataList $ SrcDirs path
index 7225687..c813f82 100644 (file)
@@ -1,12 +1,11 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Oracles.PackageData (
-    PackageData (..), PackageDataList (..), pkgData, pkgDataList, packageDataOracle
+    PackageData (..), PackageDataList (..), pkgData, pkgDataList
     ) where
 
-import Development.Shake.Config
-import qualified Data.HashMap.Strict as Map
-
-import Base
+import Data.List
+import Development.Shake
+import Hadrian.Oracles.KeyValue
+import Hadrian.Utilities
 
 data PackageData = BuildGhciLib FilePath
                  | ComponentId  FilePath
@@ -33,12 +32,8 @@ data PackageDataList = AsmSrcs        FilePath
                      | Modules        FilePath
                      | SrcDirs        FilePath
 
-newtype PackageDataKey = PackageDataKey (FilePath, String)
-    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
-
 askPackageData :: FilePath -> String -> Action String
-askPackageData path key = fromMaybe "" <$>
-    askOracle (PackageDataKey (path -/- "package-data.mk", key))
+askPackageData path = lookupValueOrEmpty (path -/- "package-data.mk")
 
 -- | For each @PackageData path@ the file 'path/package-data.mk' contains a line
 -- of the form 'path_VERSION = 1.2.3.4'. @pkgData (PackageData path)@ is an
@@ -76,12 +71,3 @@ pkgDataList packageData = fmap (map unquote . words) $ case packageData of
     SrcDirs        path -> askPackageData path "HS_SRC_DIRS"
   where
     unquote = dropWhile (== '\'') . dropWhileEnd (== '\'')
-
--- | Oracle for 'package-data.mk' files.
-packageDataOracle :: Rules ()
-packageDataOracle = void $ do
-    keys <- newCache $ \file -> do
-        need [file]
-        putLoud $ "Reading " ++ file ++ "..."
-        liftIO $ readConfigFile file
-    addOracle $ \(PackageDataKey (file, key)) -> Map.lookup key <$> keys file
index d6589f8..d74a15c 100644 (file)
@@ -6,7 +6,7 @@ module Oracles.Setting (
     relocatableBuild, installDocDir, installGhcLibDir
     ) where
 
-import Hadrian.Oracles.Config
+import Hadrian.Oracles.KeyValue
 
 import Base
 import Stage
@@ -74,7 +74,7 @@ data SettingList = ConfCcArgs Stage
 
 -- | Maps 'Setting's to names in @cfg/system.config.in@.
 setting :: Setting -> Action String
-setting key = unsafeAskConfig $ case key of
+setting key = lookupValueOrError configFile $ case key of
     BuildArch          -> "build-arch"
     BuildOs            -> "build-os"
     BuildPlatform      -> "build-platform"
@@ -122,7 +122,7 @@ setting key = unsafeAskConfig $ case key of
     LnS                -> "ln-s"
 
 settingList :: SettingList -> Action [String]
-settingList key = fmap words $ unsafeAskConfig $ case key of
+settingList key = fmap words $ lookupValueOrError configFile $ case key of
     ConfCcArgs        stage -> "conf-cc-args-"         ++ stageString stage
     ConfCppArgs       stage -> "conf-cpp-args-"        ++ stageString stage
     ConfGccLinkerArgs stage -> "conf-gcc-linker-args-" ++ stageString stage
index d73221c..5f1f55e 100644 (file)
@@ -1,23 +1,21 @@
 module Rules.Oracles (oracleRules) where
 
 import qualified Hadrian.Oracles.ArgsHash
-import qualified Hadrian.Oracles.Config
 import qualified Hadrian.Oracles.DirectoryContents
+import qualified Hadrian.Oracles.KeyValue
 import qualified Hadrian.Oracles.Path
 
 import Base
 import qualified Oracles.Dependencies
 import qualified Oracles.ModuleFiles
-import qualified Oracles.PackageData
 import Target
 import Settings
 
 oracleRules :: Rules ()
 oracleRules = do
     Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs
-    Hadrian.Oracles.Config.configOracle configFile
     Hadrian.Oracles.DirectoryContents.directoryContentsOracle
+    Hadrian.Oracles.KeyValue.keyValueOracle
     Hadrian.Oracles.Path.pathOracle
     Oracles.Dependencies.dependenciesOracles
     Oracles.ModuleFiles.moduleFilesOracle
-    Oracles.PackageData.packageDataOracle
index 6dc1b31..f9694a9 100644 (file)
@@ -6,7 +6,7 @@ module Settings (
     integerLibraryName, destDir, pkgConfInstallPath, stage1Only
     ) where
 
-import Hadrian.Oracles.Config
+import Hadrian.Oracles.KeyValue
 import Hadrian.Oracles.Path
 
 import Base
@@ -107,7 +107,7 @@ systemBuilderPath builder = case builder of
     fromKey key = do
         let unpack = fromMaybe . error $ "Cannot find path to builder "
                 ++ quote key ++ " in system.config file. Did you skip configure?"
-        path <- unpack <$> askConfig key
+        path <- unpack <$> lookupValue configFile key
         if null path
         then do
             unless (isOptional builder) . error $ "Non optional builder "