Commit 4f0b5a13 authored by Andrey Mokhov's avatar Andrey Mokhov

Re-export basic data type definitions from Base

parent a395dd71
......@@ -2,38 +2,43 @@ module Base (
-- * General utilities
module Control.Applicative,
module Control.Monad.Extra,
module Data.Bifunctor,
module Data.Function,
module Data.List.Extra,
module Data.Maybe,
module Data.Semigroup,
module Hadrian.Utilities,
-- * Shake
module Development.Shake,
module Development.Shake.Classes,
module Development.Shake.FilePath,
module Development.Shake.Util,
-- * Paths
configPath, configFile, sourcePath,
-- * Basic data types
module Builder,
module Package,
module Stage,
module Way,
-- * Miscellaneous utilities
unifyPath, quote, (-/-)
-- * Paths
configPath, configFile, sourcePath, configH
) where
import Control.Applicative
import Control.Monad.Extra
import Control.Monad.Reader
import Data.Bifunctor
import Data.Function
import Data.List.Extra
import Data.Maybe
import Data.Semigroup
import Development.Shake hiding (parallel, unit, (*>), Normal)
import Development.Shake.Classes
import Development.Shake.FilePath
import Development.Shake.Util
import Hadrian.Utilities
-- TODO: reexport Stage, etc.?
import Builder
import Package
import Stage
import Way
-- | Hadrian lives in 'hadrianPath' directory of the GHC tree.
hadrianPath :: FilePath
......@@ -43,6 +48,7 @@ hadrianPath = "hadrian"
configPath :: FilePath
configPath = hadrianPath -/- "cfg"
-- | Path to the file with configuration settings.
configFile :: FilePath
configFile = configPath -/- "system.config"
......@@ -50,3 +56,8 @@ configFile = configPath -/- "system.config"
-- sourcePath -/- "Base.hs". We use this to `need` some of the source files.
sourcePath :: FilePath
sourcePath = hadrianPath -/- "src"
-- TODO: change @mk/config.h@ to @shake-build/cfg/config.h@
-- | Path to the generated @mk/config.h file.
configH :: FilePath
configH = "mk/config.h"
\ No newline at end of file
{-# LANGUAGE DeriveGeneric, FlexibleInstances, LambdaCase #-}
{-# LANGUAGE DeriveGeneric, LambdaCase #-}
module Builder (
CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..), isOptional, builder
CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..), isOptional
) where
import Development.Shake.Classes
import GHC.Generics
import Hadrian.Expression
import Base
import Context
import Stage
-- | C compiler can be used in two different modes:
......@@ -84,38 +82,3 @@ isOptional = \case
HsColour -> True
Objdump -> True
_ -> False
-- | This type class allows the user to construct both precise builder
-- predicates, such as @builder (Ghc CompileHs Stage1)@, as well as predicates
-- covering a set of similar builders. For example, @builder (Ghc CompileHs)@
-- matches any stage, and @builder Ghc@ matches any stage and any GHC mode.
class BuilderPredicate a where
-- | Is a particular builder being used?
builder :: a -> Predicate Context Builder
instance BuilderPredicate Builder where
builder b = (b ==) <$> getBuilder
instance BuilderPredicate a => BuilderPredicate (Stage -> a) where
builder f = builder . f =<< getStage
instance BuilderPredicate a => BuilderPredicate (CcMode -> a) where
builder f = do
b <- getBuilder
case b of
Cc c _ -> builder (f c)
_ -> return False
instance BuilderPredicate a => BuilderPredicate (GhcMode -> a) where
builder f = do
b <- getBuilder
case b of
Ghc c _ -> builder (f c)
_ -> return False
instance BuilderPredicate a => BuilderPredicate (FilePath -> a) where
builder f = do
b <- getBuilder
case b of
Configure path -> builder (f path)
_ -> return False
{-# LANGUAGE DeriveGeneric #-}
module Context (
Context (..), vanillaContext, stageContext, getStage, getPackage, getWay
Context (..), vanillaContext, stageContext, getStage, getPackage, getWay,
getStagedSettingList
) where
import GHC.Generics
import Hadrian.Expression
import Base
import Package
import Stage
import Way
import Oracles.Setting
-- | Build context for a currently built 'Target'. We generate potentially
-- different build rules for each 'Context'.
......@@ -44,3 +43,6 @@ getPackage = package <$> getContext
getWay :: Expr Context b Way
getWay = way <$> getContext
-- | Get a list of configuration settings for the current stage.
getStagedSettingList :: (Stage -> SettingList) -> Args Context b
getStagedSettingList f = getSettingList . f =<< getStage
{-# LANGUAGE FlexibleInstances #-}
module Expression (
-- * Expressions
Expr, Predicate, Args, Ways, Packages,
......@@ -7,7 +8,7 @@ module Expression (
-- ** Predicates
(?), stage, stage0, stage1, stage2, notStage0, package, notPackage,
libraryPackage, way, input, inputs, output, outputs,
libraryPackage, builder, way, input, inputs, output, outputs,
-- ** Evaluation
interpret, interpretInContext,
......@@ -17,7 +18,7 @@ module Expression (
-- * Convenient accessors
getContext, getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
getInput, getOutput, getSetting, getSettingList, getStagedSettingList,
getInput, getOutput,
-- * Re-exports
module Data.Semigroup,
......@@ -40,8 +41,6 @@ import Stage
import Target hiding (builder, inputs, outputs)
import Way
import Oracles.Setting
-- | @Expr a@ is a computation that produces a value of type @Action a@ and can
-- read parameters of the current build 'Target'.
type Expr a = H.Expr Context Builder a
......@@ -54,18 +53,6 @@ type Args = H.Args Context Builder
type Packages = Expr [Package]
type Ways = Expr [Way]
-- | Get a configuration setting.
getSetting :: Setting -> Expr String
getSetting = expr . setting
-- | Get a list of configuration settings.
getSettingList :: SettingList -> Args
getSettingList = expr . settingList
-- | Get a list of configuration settings for the current stage.
getStagedSettingList :: (Stage -> SettingList) -> Args
getStagedSettingList f = getSettingList . f =<< getStage
-- | Is the build currently in the provided stage?
stage :: Stage -> Predicate
stage s = (s ==) <$> getStage
......@@ -74,6 +61,41 @@ stage s = (s ==) <$> getStage
package :: Package -> Predicate
package p = (p ==) <$> getPackage
-- | This type class allows the user to construct both precise builder
-- predicates, such as @builder (Ghc CompileHs Stage1)@, as well as predicates
-- covering a set of similar builders. For example, @builder (Ghc CompileHs)@
-- matches any stage, and @builder Ghc@ matches any stage and any GHC mode.
class BuilderPredicate a where
-- | Is a particular builder being used?
builder :: a -> Predicate
instance BuilderPredicate Builder where
builder b = (b ==) <$> getBuilder
instance BuilderPredicate a => BuilderPredicate (Stage -> a) where
builder f = builder . f =<< getStage
instance BuilderPredicate a => BuilderPredicate (CcMode -> a) where
builder f = do
b <- getBuilder
case b of
Cc c _ -> builder (f c)
_ -> return False
instance BuilderPredicate a => BuilderPredicate (GhcMode -> a) where
builder f = do
b <- getBuilder
case b of
Ghc c _ -> builder (f c)
_ -> return False
instance BuilderPredicate a => BuilderPredicate (FilePath -> a) where
builder f = do
b <- getBuilder
case b of
Configure path -> builder (f path)
_ -> return False
-- | Is the current build 'Way' equal to a certain value?
way :: Way -> Predicate
way w = (w ==) <$> getWay
......
......@@ -5,7 +5,6 @@ module Oracles.Dependencies (
) where
import qualified Data.HashMap.Strict as Map
import Hadrian.Utilities
import Base
import Context
......
......@@ -4,11 +4,9 @@ module Oracles.ModuleFiles (
) where
import qualified Data.HashMap.Strict as Map
import Hadrian.Utilities
import Base
import Context
import Expression
import Oracles.PackageData
import Settings.Path
......
module Oracles.Setting (
Setting (..), SettingList (..), setting, settingList,
anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs,
configFile, Setting (..), SettingList (..), setting, settingList, getSetting,
getSettingList, anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs,
ghcWithInterpreter, ghcEnableTablesNextToCode, useLibFFIForAdjustors,
ghcCanonVersion, cmdLineLengthLimit, iosHost, osxHost, windowsHost,
relocatableBuild, installDocDir, installGhcLibDir
topDirectory, relocatableBuild, installDocDir, installGhcLibDir, libsuf
) where
import Development.Shake
import Hadrian.Expression
import Hadrian.Oracles.KeyValue
import Hadrian.Oracles.Path
import Base
import Stage
-- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions).
-- | Each 'Setting' comes from @system.config@ file, e.g. 'target-os = mingw32'.
......@@ -129,6 +131,14 @@ settingList key = fmap words $ lookupValueOrError configFile $ case key of
ConfLdLinkerArgs stage -> "conf-ld-linker-args-" ++ stageString stage
HsCppArgs -> "hs-cpp-args"
-- | Get a configuration setting.
getSetting :: Setting -> Expr c b String
getSetting = expr . setting
-- | Get a list of configuration settings.
getSettingList :: SettingList -> Args c b
getSettingList = expr . settingList
matchSetting :: Setting -> [String] -> Action Bool
matchSetting key values = fmap (`elem` values) $ setting key
......@@ -207,6 +217,10 @@ installDocDir = do
dataDir <- setting InstallDataRootDir
return $ dataDir -/- ("doc/ghc-" ++ version)
-- | Path to the GHC source tree.
topDirectory :: Action FilePath
topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
-- ref: mk/install.mk:101
-- TODO: CroosCompilePrefix
-- | Unix: override @libdir@ and @datadir@ to put GHC-specific files in a
......@@ -219,3 +233,20 @@ installGhcLibDir = do
else do
version <- setting ProjectVersion
return $ libdir -/- ("ghc-" ++ version)
-- TODO: find out why we need version number in the dynamic suffix
-- The current theory: dynamic libraries are eventually placed in a single
-- giant directory in the load path of the dynamic linker, and hence we must
-- distinguish different versions of GHC. In contrast static libraries live
-- in their own per-package directory and hence do not need a unique filename.
-- We also need to respect the system's dynamic extension, e.g. .dll or .so.
libsuf :: Way -> Action String
libsuf way =
if (not . wayUnit Dynamic $ way)
then return $ waySuffix way ++ ".a" -- e.g., _p.a
else do
extension <- setting DynamicExtension -- e.g., .dll or .so
version <- setting ProjectVersion -- e.g., 7.11.20141222
let prefix = wayPrefix $ removeWayUnit Dynamic way
-- e.g., p_ghc7.11.20141222.dll (the result)
return $ prefix ++ "-ghc" ++ version ++ extension
......@@ -8,9 +8,10 @@ module Package (
) where
import Data.String
import Development.Shake.Classes
import Development.Shake.FilePath
import GHC.Generics
import Base
import Hadrian.Utilities
-- | The name of a Cabal package.
newtype PackageName = PackageName { fromPackageName :: String }
......@@ -28,6 +29,24 @@ data Package = Package
, pkgType :: PackageType -- ^ A library or a program.
} deriving Generic
-- TODO: Get rid of non-derived Show instances.
instance Show Package where
show = pkgNameString
instance Eq Package where
p == q = pkgName p == pkgName q
instance Ord Package where
compare p q = compare (pkgName p) (pkgName q)
instance Binary Package
instance Hashable Package
instance NFData Package
instance Binary PackageType
instance Hashable PackageType
instance NFData PackageType
-- | Prettyprint 'Package' name.
pkgNameString :: Package -> String
pkgNameString = fromPackageName . pkgName
......@@ -65,21 +84,3 @@ isLibrary _ = False
isProgram :: Package -> Bool
isProgram (Package _ _ Program) = True
isProgram _ = False
-- TODO: Get rid of non-derived Show instances.
instance Show Package where
show = pkgNameString
instance Eq Package where
(==) = (==) `on` pkgName
instance Ord Package where
compare = compare `on` pkgName
instance Binary Package
instance Hashable Package where
instance NFData Package
instance Binary PackageType
instance Hashable PackageType
instance NFData PackageType
......@@ -8,7 +8,6 @@ import Distribution.Types.CondTree
import Distribution.Verbosity
import Base
import Expression hiding (package)
import GHC
import Settings
import Settings.Path
......
......@@ -2,7 +2,6 @@ module Rules.Clean (clean, cleanSourceTree, cleanRules) where
import Base
import Settings.Path
import Stage
import UserSettings
import Util
......
module Rules.Compile (compilePackage) where
import Development.Shake.Util
import Base
import Context
import Expression
......
......@@ -3,12 +3,9 @@ module Rules.Configure (configureRules) where
import qualified System.Info as System
import Base
import Builder
import CmdLineFlag
import Context
import GHC
import Settings.Path
import Stage
import Target
import UserSettings
import Util
......
module Rules.Dependencies (buildPackageDependencies) where
import Development.Shake.Util
import Data.Bifunctor
import Data.Function
import Base
import Context
......
......@@ -3,8 +3,6 @@ module Rules.Generate (
copyRules, includesDependencies, generatedDependencies
) where
import Hadrian.Utilities
import Base
import Context hiding (package)
import Expression
......
module Rules.Gmp (gmpRules) where
import Hadrian.Utilities
import Base
import Builder
import GHC
import Oracles.Setting
import Package
import Settings.Packages.IntegerGmp
import Settings.Path
import Stage
import Target
import UserSettings
import Util
......
......@@ -3,7 +3,6 @@ module Rules.Library (
) where
import Data.Char
import Hadrian.Utilities
import qualified System.Directory as IO
import Base
......@@ -11,9 +10,10 @@ import Context
import Expression hiding (way, package)
import Flavour
import GHC
import Oracles.Dependencies
import Oracles.ModuleFiles
import Oracles.PackageData
import Oracles.Dependencies
import Oracles.Setting
import Settings
import Settings.Path
import Target
......
module Rules.Perl (perlScriptRules) where
import Base
import Expression
import Util
-- | Build Perl scripts, such as @ghc-split@, from their literate Perl sources.
......
module Rules.Register (registerPackage) where
import Hadrian.Utilities
import Base
import Context
import Expression
import GHC
import Settings.Path
import Target
......
......@@ -3,11 +3,9 @@
module Rules.Selftest (selftestRules) where
import Development.Shake
import Hadrian.Utilities
import Test.QuickCheck
import Base
import Expression
import GHC
import Oracles.ModuleFiles
import Oracles.Setting
......@@ -64,7 +62,7 @@ testLookupAll = do
in lookupAll items (sort dict) == map (flip lookup dict) items
where
dicts :: Gen [(Int, Int)]
dicts = nubBy ((==) `on` fst) <$> vector 20
dicts = nubBy (\x y -> fst x == fst y) <$> vector 20
extras :: Gen [Int]
extras = vector 20
......
......@@ -3,7 +3,6 @@ module Rules.SourceDist (sourceDistRules) where
import Hadrian.Oracles.DirectoryContents
import Base
import Builder
import Oracles.Setting
import Rules.Clean
import UserSettings
......
module Rules.Test (testRules) where
import Hadrian.Utilities
import Base
import Builder
import Expression
import Flavour
import GHC
......
module Settings.Builders.Common (
module Base,
module Context,
module Expression,
module GHC,
module Oracles.Flag,
......@@ -12,6 +13,7 @@ module Settings.Builders.Common (
) where
import Base
import Context (getStagedSettingList)
import Expression
import GHC
import Oracles.Flag
......
module Settings.Packages.Rts (rtsPackageArgs, rtsLibffiLibrary) where
import Hadrian.Utilities
import Base
import Expression
import GHC
......
module Settings.Path (
stageDirectory, buildPath, pkgDataFile, pkgHaddockFile, pkgLibraryFile,
pkgLibraryFile0, pkgGhciLibraryFile, gmpContext, gmpBuildPath, gmpObjects,
gmpLibraryH, gmpBuildInfoPath, generatedPath, libffiContext, libffiBuildPath,
rtsContext, rtsBuildPath, rtsConfIn, shakeFilesPath,inplacePackageDbDirectory,
pkgConfFile, packageDbStamp, bootPackageConstraints, packageDependencies,
objectPath, inplaceBinPath, inplaceLibBinPath, inplaceLibPath, configH,
inplaceInstallPath, autogenPath, pkgInplaceConfig, ghcSplitPath, stripCmdPath,
pkgSetupConfigFile, inplaceLibCopyTargets, templateHscPath, topDirectory
) where
-- * Hadrian configuration and source files
shakeFilesPath, bootPackageConstraints, packageDependencies,
-- * Build artefacts
buildPath, stageDirectory, pkgDataFile, pkgHaddockFile, pkgLibraryFile,
pkgLibraryFile0, pkgGhciLibraryFile, generatedPath, inplacePackageDbDirectory,
pkgConfFile, packageDbStamp, objectPath, autogenPath, pkgInplaceConfig,
pkgSetupConfigFile,
-- * RTS library
rtsContext, rtsBuildPath, rtsConfIn,
-- * GMP library
gmpContext, gmpBuildPath, gmpObjects, gmpLibraryH, gmpBuildInfoPath,
-- * LibFFI library
libffiContext, libffiBuildPath,
import Hadrian.Oracles.Path
-- * Installation
inplaceBinPath, inplaceLibBinPath, inplaceLibPath, inplaceInstallPath,
inplaceLibCopyTargets, templateHscPath,
-- * Miscellaneous
ghcSplitPath, stripCmdPath
) where
import Base
import Context
import Expression hiding (stage)
import GHC
import Oracles.PackageData
import Oracles.Setting
......@@ -24,10 +37,6 @@ import UserSettings
shakeFilesPath :: FilePath
shakeFilesPath = buildRootPath -/- "hadrian"
-- | Path to the GHC source tree.
topDirectory :: Action FilePath
topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
-- | Boot package versions extracted from @.cabal@ files.
bootPackageConstraints :: FilePath
bootPackageConstraints = shakeFilesPath -/- "boot-package-constraints"
......@@ -45,38 +54,10 @@ generatedPath = buildRootPath -/- "generated"
stageDirectory :: Stage -> FilePath
stageDirectory = stageString
-- TODO: change @mk/config.h@ to @shake-build/cfg/config.h@