Commit 15acc2cd authored by Andrey Mokhov's avatar Andrey Mokhov

Minor revision

parent 8933a3a8
......@@ -22,7 +22,7 @@ import Stage
data CompilerMode = Compile
| FindDependencies
| Link
deriving (Show, Eq, Generic)
deriving (Eq, Generic, Show)
-- TODO: Do we really need HsCpp builder? Can't we use Cc instead?
-- | A 'Builder' is an external command invoked in separate process using 'Shake.cmd'
......@@ -57,7 +57,7 @@ data Builder = Alex
| Ranlib
| Tar
| Unlit
deriving (Show, Eq, Generic)
deriving (Eq, Generic, Show)
-- | Some builders are built by this very build system, in which case
-- 'builderProvenance' returns the corresponding build 'Context' (which includes
......@@ -93,7 +93,7 @@ isOptional = \case
Objdump -> True
_ -> False
-- TODO: get rid of fromJust
-- TODO: Get rid of fromJust.
-- | Determine the location of a 'Builder'.
builderPath :: Builder -> Action FilePath
builderPath builder = case builderProvenance builder of
......@@ -121,14 +121,14 @@ builderPath builder = case builderProvenance builder of
_ -> error $ "Cannot determine builderPath for " ++ show builder
where
fromKey key = do
path <- askConfigWithDefault key . error $ "\nCannot find path to "
++ quote key ++ " in system.config file. Did you skip configure?"
let unpack = fromMaybe . error $ "Cannot find path to builder "
++ quote key ++ " in system.config file. Did you skip configure?"
path <- unpack <$> askConfig key
if null path
then do
if isOptional builder
then return ""
else error $ "Builder " ++ quote key ++ " is not specified in"
++ " system.config file. Cannot proceed without it."
unless (isOptional builder) . error $ "Non optional builder "
++ quote key ++ " is not specified in system.config file."
return "" -- TODO: Use a safe interface.
else fixAbsolutePathOnWindows =<< lookupInPath path
getBuilderPath :: Builder -> ReaderT a Action FilePath
......@@ -141,6 +141,7 @@ builderEnvironment variable builder = do
path <- builderPath builder
return $ AddEnv variable path
-- | Was the path to a given 'Builder' specified in configuration files?
specified :: Builder -> Action Bool
specified = fmap (not . null) . builderPath
......@@ -152,7 +153,7 @@ needBuilder = \case
path <- builderPath builder
need [path]
-- Instances for storing in the Shake database
-- | Instances for storing in the Shake database.
instance Binary CompilerMode
instance Hashable CompilerMode
instance NFData CompilerMode
......
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances, LambdaCase #-}
module Expression (
-- * Expressions
Expr, DiffExpr, fromDiffExpr,
......@@ -207,8 +207,6 @@ getOutput = do
"getOutput: exactly one output file expected in target " ++ show target
getSingleton :: Expr [a] -> String -> Expr a
getSingleton expr msg = do
xs <- expr
case xs of
[res] -> return res
_ -> error msg
getSingleton expr msg = expr >>= \case
[res] -> return res
_ -> error msg
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Oracles.Config (askConfig, askConfigWithDefault, configOracle) where
module Oracles.Config (askConfig, unsafeAskConfig, configOracle) where
import qualified Data.HashMap.Strict as Map
import Development.Shake.Config
......@@ -9,23 +9,19 @@ import Base
newtype ConfigKey = ConfigKey String
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
askConfig :: String -> Action String
askConfig key = askConfigWithDefault key . error
$ "Cannot find key " ++ quote key ++ " in configuration files."
unsafeAskConfig :: String -> Action String
unsafeAskConfig key = (fromMaybe $ error msg) <$> askConfig key
where
msg = "Key " ++ quote key ++ " not found in configuration files."
askConfigWithDefault :: String -> Action String -> Action String
askConfigWithDefault key defaultAction = do
maybeValue <- askOracle $ ConfigKey key
case maybeValue of
Just value -> return value
Nothing -> defaultAction
askConfig :: String -> Action (Maybe String)
askConfig = askOracle . ConfigKey
-- Oracle for configuration files
configOracle :: Rules ()
configOracle = do
configOracle = void $ do
cfg <- newCache $ \() -> do
need [configFile]
putLoud $ "Reading " ++ configFile ++ "..."
liftIO $ readConfigFile configFile
_ <- addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()
return ()
addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()
......@@ -25,23 +25,21 @@ data Flag = ArSupportsAtFile
-- fragile, but some flags do behave like this, e.g. GccIsClang.
flag :: Flag -> Action Bool
flag f = do
key <- return $ case f of
ArSupportsAtFile -> "ar-supports-at-file"
CrossCompiling -> "cross-compiling"
GccIsClang -> "gcc-is-clang"
GccLt46 -> "gcc-lt-46"
GhcUnregisterised -> "ghc-unregisterised"
LeadingUnderscore -> "leading-underscore"
SolarisBrokenShld -> "solaris-broken-shld"
SplitObjectsBroken -> "split-objects-broken"
SupportsThisUnitId -> "supports-this-unit-id"
WithLibdw -> "with-libdw"
UseSystemFfi -> "use-system-ffi"
value <- askConfigWithDefault key . error
$ "\nFlag " ++ quote key ++ " not set in configuration files."
unless (value == "YES" || value == "NO" || value == "") . error
$ "\nFlag " ++ quote key ++ " is set to " ++ quote value
++ " instead of 'YES' or 'NO'."
let key = case f of
ArSupportsAtFile -> "ar-supports-at-file"
CrossCompiling -> "cross-compiling"
GccIsClang -> "gcc-is-clang"
GccLt46 -> "gcc-lt-46"
GhcUnregisterised -> "ghc-unregisterised"
LeadingUnderscore -> "leading-underscore"
SolarisBrokenShld -> "solaris-broken-shld"
SplitObjectsBroken -> "split-objects-broken"
SupportsThisUnitId -> "supports-this-unit-id"
WithLibdw -> "with-libdw"
UseSystemFfi -> "use-system-ffi"
value <- unsafeAskConfig key
when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag "
++ quote (key ++ " = " ++ value) ++ "cannot be parsed."
return $ value == "YES"
getFlag :: Flag -> ReaderT a Action Bool
......
......@@ -59,7 +59,7 @@ data SettingList = ConfCcArgs Stage
| HsCppArgs
setting :: Setting -> Action String
setting key = askConfig $ case key of
setting key = unsafeAskConfig $ case key of
BuildArch -> "build-arch"
BuildOs -> "build-os"
BuildPlatform -> "build-platform"
......@@ -96,7 +96,7 @@ setting key = askConfig $ case key of
IconvLibDir -> "iconv-lib-dir"
settingList :: SettingList -> Action [String]
settingList key = fmap words $ askConfig $ case key of
settingList key = fmap words $ unsafeAskConfig $ 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
......
......@@ -41,18 +41,11 @@ newtype PkgDepsKey = PkgDepsKey String
-- compute package dependencies we scan package cabal files, see "Rules.Cabal".
contextDependencies :: Context -> Action [Context]
contextDependencies context@Context {..} = do
maybeDeps <- askOracle . PkgDepsKey $ pkgNameString package
deps <- case maybeDeps of
Nothing -> error $ "Context dependencies not found for " ++ show context
Just ds -> return $ map PackageName ds
let pkgContext = \pkg -> Context (min stage Stage1) pkg way
pkgs <- interpretInContext (pkgContext package) getPackages
return . map pkgContext $ matchPackageNames (sort pkgs) deps
-- | Given a sorted list of packages and a sorted list of package names, returns
-- packages whose names appear in the list of names.
matchPackageNames :: [Package] -> [PackageName] -> [Package]
matchPackageNames = intersectOrd (\pkg name -> compare (pkgName pkg) name)
unpack = fromMaybe . error $ "No dependencies for " ++ show context
deps <- unpack <$> askOracle (PkgDepsKey $ pkgNameString package)
pkgs <- sort <$> interpretInContext (pkgContext package) getPackages
return . map pkgContext $ intersectOrd (compare . pkgNameString) pkgs deps
-- | Coarse-grain 'need': make sure given contexts are fully built.
needContext :: [Context] -> Action ()
......@@ -71,14 +64,13 @@ needContext cs = do
-- | Oracles for the package dependencies and 'path/dist/.dependencies' files.
dependenciesOracles :: Rules ()
dependenciesOracles = do
deps <- newCache $ \file -> do
putLoud $ "Reading dependencies from " ++ file ++ "..."
contents <- map words <$> readFileLines file
return . Map.fromList $ map (\(x:xs) -> (x, xs)) contents
deps <- newCache readDependencies
void $ addOracle $ \(ObjDepsKey (file, obj)) -> Map.lookup obj <$> deps file
pkgDeps <- newCache $ \_ -> do
putLoud $ "Reading package dependencies..."
contents <- readFileLines packageDependencies
return $ Map.fromList [ (p, ps) | s <- contents, let p:ps = words s ]
pkgDeps <- newCache $ \_ -> readDependencies packageDependencies
void $ addOracle $ \(PkgDepsKey pkg) -> Map.lookup pkg <$> pkgDeps ()
where
readDependencies file = do
putLoud $ "Reading dependencies from " ++ file ++ "..."
contents <- map words <$> readFileLines file
return $ Map.fromList [ (key, values) | (key:values) <- contents ]
......@@ -17,9 +17,7 @@ lookupInPath name
lookupInPathOracle :: Rules ()
lookupInPathOracle = void $
addOracle $ \(LookupInPath name) -> do
maybePath <- liftIO $ findExecutable name
path <- case maybePath of
Just value -> return $ unifyPath value
Nothing -> error $ "Cannot find executable '" ++ name ++ "'."
let unpack = fromMaybe . error $ "Cannot find executable " ++ quote name
path <- unifyPath <$> unpack <$> liftIO (findExecutable name)
putLoud $ "Executable found: " ++ name ++ " => " ++ path
return path
......@@ -78,7 +78,7 @@ haskellSources context = do
let autogen = buildPath context -/- "autogen"
-- Generated source files live in buildPath and have extension "hs", except
-- for GHC/Prim.hs that lives in autogen. TODO: fix the inconsistency?
let modFile ("GHC.Prim", _) = autogen -/- "GHC/Prim.hs"
modFile ("GHC.Prim", _) = autogen -/- "GHC/Prim.hs"
modFile (m, Nothing ) = generatedFile context m
modFile (m, Just file )
| takeExtension file `elem` haskellExtensions = file
......
......@@ -38,10 +38,7 @@ askPackageData :: FilePath -> String -> Action String
askPackageData path key = do
let fullKey = replaceSeparators '_' $ path ++ "_" ++ key
file = path -/- "package-data.mk"
maybeValue <- askOracle $ PackageDataKey (file, fullKey)
case maybeValue of
Nothing -> return ""
Just value -> return value
fromMaybe "" <$> askOracle (PackageDataKey (file, fullKey))
-- | 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
......
{-# LANGUAGE LambdaCase, FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances, LambdaCase #-}
-- | Convenient predicates
module Predicate (
module Expression,
stage, stage0, stage1, stage2, notStage0,
package, notPackage, builder, input, output, way
module Expression, stage, stage0, stage1, stage2, notStage0, builder,
package, notPackage, input, output, way
) where
import Base
......
......@@ -107,10 +107,8 @@ generatePackageCode context@(Context stage pkg _) =
file <~ gen = generate file context gen
in do
generated ?> \file -> do
maybeValue <- findGenerator context file
(src, builder) <- case maybeValue of
Nothing -> error $ "No generator for " ++ file ++ "."
Just value -> return value
let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
(src, builder) <- unpack <$> findGenerator context file
need [src]
build $ Target context builder [src] [file]
let srcBoot = src -<.> "hs-boot"
......
......@@ -54,7 +54,7 @@ gmpRules = do
-- That's because the doc/ directory contents are under the GFDL,
-- which causes problems for Debian.
tarballs <- getDirectoryFiles "" [gmpBase -/- "tarball/gmp*.tar.bz2"]
tarball <- case tarballs of
tarball <- case tarballs of -- TODO: Drop code duplication.
[file] -> return $ unifyPath file
_ -> error $ "gmpRules: exactly one tarball expected"
++ "(found: " ++ show tarballs ++ ")."
......@@ -70,11 +70,10 @@ gmpRules = do
copyFile src patchPath
applyPatch tmp patch
let name = dropExtension . dropExtension $ takeFileName tarball
libName <- case stripSuffix "-nodoc-patched" name of
Just rest -> return rest
Nothing -> error $ "gmpRules: expected suffix "
let name = dropExtension . dropExtension $ takeFileName tarball
unpack = fromMaybe . error $ "gmpRules: expected suffix "
++ "-nodoc-patched (found: " ++ name ++ ")."
libName = unpack $ stripSuffix "-nodoc-patched" name
moveDirectory (tmp -/- libName) gmpBuildPath
......
......@@ -72,7 +72,7 @@ libffiRules = do
createDirectory $ buildRootPath -/- stageString Stage0
tarballs <- getDirectoryFiles "" ["libffi-tarballs/libffi*.tar.gz"]
tarball <- case tarballs of
tarball <- case tarballs of -- TODO: Drop code duplication.
[file] -> return $ unifyPath file
_ -> error $ "libffiRules: exactly one tarball expected"
++ "(found: " ++ show tarballs ++ ")."
......
......@@ -114,7 +114,7 @@ withBuilderKey b = case b of
Happy -> "--with-happy="
GhcPkg _ -> "--with-ghc-pkg="
HsColour -> "--with-hscolour="
_ -> error "withBuilderKey: not supported builder"
_ -> error $ "withBuilderKey: not supported builder " ++ show b
-- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
with :: Builder -> Args
......
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