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

Replace Config oracle with generic key-value text file oracle

See #347
parent acf66a3c
......@@ -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
......
{-# 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 ()
{-# 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
......@@ -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"
......
......@@ -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
......
{-# 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
......@@ -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
......
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
......@@ -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 "
......
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