Commit 2bdb94fd authored by Andrey Mokhov's avatar Andrey Mokhov

Merge Predicate into Expression

parent 8e97252e
......@@ -39,7 +39,6 @@ executable hadrian
, Oracles.ModuleFiles
, Oracles.PackageData
, Package
, Predicate
, Rules
, Rules.Cabal
, Rules.Clean
......
{-# LANGUAGE DeriveGeneric, LambdaCase #-}
{-# LANGUAGE DeriveGeneric, FlexibleInstances, LambdaCase #-}
module Builder (
CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..), isOptional
CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..), isOptional, builder
) where
import GHC.Generics
import Hadrian.Expression
import Base
import Context
import Stage
-- | A compiler can typically be used in different modes:
-- * Compiling or preprocessing a source file;
-- * Extracting source dependencies, e.g. by passing @-M@ command line argument;
-- * Linking object files & static libraries into an executable.
-- We have CcMode for C compiler and GhcMode for GHC.
data CcMode = CompileC | FindCDependencies deriving (Eq, Generic, Show)
data GhcMode = CompileCWithGhc | CompileHs | FindHsDependencies | LinkHs
-- | C compiler can be used in two different modes:
-- * Compile or preprocess a source file.
-- * Extract source dependencies by passing @-MM@ command line argument.
data CcMode = CompileC | FindCDependencies deriving (Eq, Generic, Show)
instance Binary CcMode
instance Hashable CcMode
instance NFData CcMode
-- | GHC can be used in four different modes:
-- * Compile a Haskell source file.
-- * Compile a C source file.
-- * Extract source dependencies by passing @-M@ command line argument.
-- * Link object files & static libraries into an executable.
data GhcMode = CompileHs | CompileCWithGhc | FindHsDependencies | LinkHs
deriving (Eq, Generic, Show)
instance Binary GhcMode
instance Hashable GhcMode
instance NFData GhcMode
-- | GhcPkg can initialise a package database and register packages in it.
data GhcPkgMode = Init | Update deriving (Eq, Generic, Show)
instance Binary GhcPkgMode
instance Hashable GhcPkgMode
instance NFData GhcPkgMode
-- | A 'Builder' is an external command invoked in a separate process via 'cmd'.
-- @Ghc Stage0@ is the bootstrapping compiler.
-- @Ghc StageN@, N > 0, is the one built in stage (N - 1).
......@@ -34,7 +52,7 @@ data Builder = Alex
| GenPrimopCode
| Ghc GhcMode Stage
| GhcCabal
| GhcCabalHsColour -- synonym for 'GhcCabal hscolour'
| GhcCabalHsColour -- synonym for 'GhcCabal hscolour'
| GhcPkg GhcPkgMode Stage
| Haddock
| Happy
......@@ -53,6 +71,10 @@ data Builder = Alex
| Unlit
deriving (Eq, Generic, Show)
instance Binary Builder
instance Hashable Builder
instance NFData Builder
-- TODO: Some builders are required only on certain platforms. For example,
-- Objdump is only required on OpenBSD and AIX, as mentioned in #211. Add
-- support for platform-specific optional builders as soon as we can reliably
......@@ -63,18 +85,37 @@ isOptional = \case
Objdump -> True
_ -> False
instance Binary Builder
instance Hashable Builder
instance NFData Builder
-- | 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 Binary CcMode
instance Hashable CcMode
instance NFData CcMode
instance BuilderPredicate Builder where
builder b = (b ==) <$> getBuilder
instance Binary GhcMode
instance Hashable GhcMode
instance NFData GhcMode
instance BuilderPredicate a => BuilderPredicate (Stage -> a) where
builder f = builder . f =<< getStage
instance Binary GhcPkgMode
instance Hashable GhcPkgMode
instance NFData GhcPkgMode
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) where
module Context (
Context (..), vanillaContext, stageContext, getStage, getPackage, getWay
) where
import GHC.Generics
import Hadrian.Expression
import Base
import Package
......@@ -16,6 +19,10 @@ data Context = Context
, way :: Way -- ^ Currently build Way (usually 'vanilla')
} deriving (Show, Eq, Generic)
instance Binary Context
instance Hashable Context
instance NFData Context
-- | Most targets are built only one way, hence the notion of 'vanillaContext'.
vanillaContext :: Stage -> Package -> Context
vanillaContext s p = Context s p vanilla
......@@ -25,6 +32,15 @@ vanillaContext s p = Context s p vanilla
stageContext :: Stage -> Context
stageContext s = vanillaContext s $ error "stageContext: package not set"
instance Binary Context
instance Hashable Context
instance NFData Context
-- | Get the 'Stage' of the current 'Context'.
getStage :: Expr Context b Stage
getStage = stage <$> getContext
-- | Get the 'Package' of the current 'Context'.
getPackage :: Expr Context b Package
getPackage = package <$> getContext
-- | Get the 'Way' of the current 'Context'.
getWay :: Expr Context b Way
getWay = way <$> getContext
......@@ -3,7 +3,11 @@ module Expression (
Expr, Predicate, Args, Ways, Packages,
-- ** Construction and modification
expr, exprIO, append, arg, remove, (?),
expr, exprIO, append, arg, remove,
-- ** Predicates
(?), stage, stage0, stage1, stage2, notStage0, package, notPackage,
input, inputs, output, outputs, way, libraryPackage,
-- ** Evaluation
interpret, interpretInContext,
......@@ -23,16 +27,18 @@ module Expression (
module Way
) where
import Control.Monad.Extra
import Data.Semigroup
import Development.Shake
import qualified Hadrian.Expression as H
import Hadrian.Expression hiding (Expr, Predicate, Args)
import Builder
import Context
import Context (Context, vanillaContext, stageContext, getStage, getPackage, getWay)
import Package
import Stage
import Target
import Target hiding (builder, inputs, outputs)
import Way
import Oracles.Config.Flag
......@@ -56,18 +62,6 @@ type Ways = Expr [Way]
append :: a -> Expr a
append = pure
-- | Get the 'Stage' of the current 'Context'.
getStage :: Expr Stage
getStage = stage <$> getContext
-- | Get the 'Package' of the current 'Context'.
getPackage :: Expr Package
getPackage = package <$> getContext
-- | Get the 'Way' of the current 'Context'.
getWay :: Expr Way
getWay = way <$> getContext
getSetting :: Setting -> Expr String
getSetting = expr . setting
......@@ -76,3 +70,55 @@ getSettingList = expr . settingList
getFlag :: Flag -> Predicate
getFlag = expr . flag
-- | Is the build currently in the provided stage?
stage :: Stage -> Predicate
stage s = (s ==) <$> getStage
-- | Is a particular package being built?
package :: Package -> Predicate
package p = (p ==) <$> getPackage
-- | Is the current build 'Way' equal to a certain value?
way :: Way -> Predicate
way w = (w ==) <$> getWay
-- | Is the build currently in stage 0?
stage0 :: Predicate
stage0 = stage Stage0
-- | Is the build currently in stage 1?
stage1 :: Predicate
stage1 = stage Stage1
-- | Is the build currently in stage 2?
stage2 :: Predicate
stage2 = stage Stage2
-- | Is the build /not/ in stage 0 right now?
notStage0 :: Predicate
notStage0 = notM stage0
-- | Is a certain package /not/ built right now?
notPackage :: Package -> Predicate
notPackage = notM . package
-- | Is a library package currently being built?
libraryPackage :: Predicate
libraryPackage = isLibrary <$> getPackage
-- | Does any of the input files match a given pattern?
input :: FilePattern -> Predicate
input f = any (f ?==) <$> getInputs
-- | Does any of the input files match any of the given patterns?
inputs :: [FilePattern] -> Predicate
inputs = anyM input
-- | Does any of the output files match a given pattern?
output :: FilePattern -> Predicate
output f = any (f ?==) <$> getOutputs
-- | Does any of the output files match any of the given patterns?
outputs :: [FilePattern] -> Predicate
outputs = anyM output
......@@ -9,7 +9,7 @@ import Hadrian.Utilities
import Base
import Context
import Expression
import Expression hiding (stage)
import Oracles.PackageData
import Settings
import Settings.Builders.GhcCabal
......
{-# LANGUAGE FlexibleInstances, LambdaCase #-}
-- | Convenient predicates
module Predicate (
module Expression, stage, stage0, stage1, stage2, notStage0, builder,
package, notPackage, input, inputs, output, outputs, way, libraryPackage
) where
import Base
import Expression
-- | Is the build currently in the provided stage?
stage :: Stage -> Predicate
stage s = (s ==) <$> getStage
-- | Is a particular package being built?
package :: Package -> Predicate
package p = (p ==) <$> getPackage
-- | Is a particular builder being used?
class BuilderLike a where
builder :: a -> Predicate
-- TODO: Move this elsewhere to avoid orhpan instances
instance BuilderLike Builder where
builder b = (b ==) <$> getBuilder
instance BuilderLike a => BuilderLike (Stage -> a) where
builder s2b = builder . s2b =<< getStage
instance BuilderLike a => BuilderLike (CcMode -> a) where
builder c2b = do
b <- getBuilder
case b of
Cc c _ -> builder $ c2b c
_ -> return False
instance BuilderLike a => BuilderLike (GhcMode -> a) where
builder c2b = do
b <- getBuilder
case b of
Ghc c _ -> builder $ c2b c
_ -> return False
instance BuilderLike a => BuilderLike (FilePath -> a) where
builder f2b = do
b <- getBuilder
case b of
Configure f -> builder $ f2b f
_ -> return False
-- | Does any of the input files match a given pattern?
input :: FilePattern -> Predicate
input f = any (f ?==) <$> getInputs
-- | Does any of the input files match any of the given patterns?
inputs :: [FilePattern] -> Predicate
inputs = anyM input
-- | Does any of the output files match a given pattern?
output :: FilePattern -> Predicate
output f = any (f ?==) <$> getOutputs
-- | Does any of the output files match any of the given patterns?
outputs :: [FilePattern] -> Predicate
outputs = anyM output
-- | Is the current build 'Way' equal to a certain value?
way :: Way -> Predicate
way w = (w ==) <$> getWay
-- | Is the build currently in stage 0?
stage0 :: Predicate
stage0 = stage Stage0
-- | Is the build currently in stage 1?
stage1 :: Predicate
stage1 = stage Stage1
-- | Is the build currently in stage 2?
stage2 :: Predicate
stage2 = stage Stage2
-- | Is the build /not/ in stage 0 right now?
notStage0 :: Predicate
notStage0 = notM stage0
-- | Is a certain package /not/ built right now?
notPackage :: Package -> Predicate
notPackage = notM . package
-- | Is a library package currently being built?
libraryPackage :: Predicate
libraryPackage = isLibrary <$> getPackage
......@@ -8,7 +8,7 @@ import Distribution.Types.CondTree
import Distribution.Verbosity
import Base
import Expression
import Expression hiding (package)
import GHC
import Settings
import Settings.Path
......
......@@ -2,7 +2,7 @@ module Rules.Documentation (buildPackageDocumentation) where
import Base
import Context
import Expression
import Expression hiding (way)
import Flavour
import GHC
import Oracles.ModuleFiles
......
......@@ -13,7 +13,6 @@ import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Oracles.ModuleFiles
import Predicate
import Rules.Libffi
import Settings
import Settings.Path
......
......@@ -4,9 +4,9 @@ module Rules.Install (installRules) where
import Hadrian.Oracles.DirectoryContents
import Base
import Expression hiding (builder)
import Target
import Context
import Predicate hiding (builder)
import Settings
import Settings.Path
import Util
......
......@@ -7,7 +7,7 @@ import qualified System.Directory as IO
import Base
import Context
import Expression
import Expression hiding (way, package)
import Flavour
import GHC
import Oracles.ModuleFiles
......
......@@ -4,7 +4,7 @@ import Data.Char
import Base
import Context
import Expression
import Expression hiding (stage, way)
import GHC
import Oracles.Config.Setting
import Oracles.Dependencies
......
......@@ -5,7 +5,6 @@ module Settings.Builders.Common (
module Oracles.Config.Flag,
module Oracles.Config.Setting,
module Oracles.PackageData,
module Predicate,
module Settings,
module Settings.Path,
module UserSettings,
......@@ -19,7 +18,6 @@ import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Oracles.PackageData
import Predicate
import Settings
import Settings.Path
import UserSettings
......
......@@ -5,12 +5,12 @@ module Settings.Default (
) where
import CmdLineFlag
import Expression
import Flavour
import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Oracles.PackageData
import Predicate
import Settings
import Settings.Builders.Alex
import Settings.Builders.Ar
......
......@@ -5,7 +5,7 @@ module Settings.Default (
) where
import Flavour
import Predicate
import Expression
data SourceArgs = SourceArgs
{ hsDefault :: Args
......
module Settings.Flavours.Development (developmentFlavour) where
import Flavour
import Predicate
import Expression
import {-# SOURCE #-} Settings.Default
-- TODO: Implement an equivalent of LAX_DEPENDENCIES = YES setting, see #250.
......
module Settings.Flavours.Performance (performanceFlavour) where
import Flavour
import Predicate
import Expression
import {-# SOURCE #-} Settings.Default
performanceFlavour :: Flavour
......
module Settings.Flavours.Profiled (profiledFlavour) where
import Flavour
import Predicate
import Expression
import {-# SOURCE #-} Settings.Default
profiledFlavour :: Flavour
......
module Settings.Flavours.Quick (quickFlavour) where
import Flavour
import Predicate
import Expression
import Oracles.Config.Flag (platformSupportsSharedLibs)
import {-# SOURCE #-} Settings.Default
......
module Settings.Flavours.Quickest (quickestFlavour) where
import Flavour
import Predicate
import Expression
import {-# SOURCE #-} Settings.Default
quickestFlavour :: Flavour
......
module Settings.Packages.Base (basePackageArgs) where
import Expression
import GHC
import Predicate
import Settings
basePackageArgs :: Args
......
module Settings.Packages.Cabal where
import GHC
import Predicate
import Expression
cabalPackageArgs :: Args
cabalPackageArgs = package cabal ? do
......
module Settings.Packages.Compiler (compilerPackageArgs) where
import Base
import Expression
import Flavour
import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Predicate
import Settings
compilerPackageArgs :: Args
......
module Settings.Packages.Ghc (ghcPackageArgs) where
import GHC
import Expression
import Oracles.Config.Setting
import Predicate
import Settings.Path
ghcPackageArgs :: Args
......
module Settings.Packages.GhcCabal (ghcCabalPackageArgs) where
import Distribution.Package (pkgVersion)
import Distribution.PackageDescription (packageDescription)
import Distribution.PackageDescription.Parse
import qualified Distribution.PackageDescription as DP
import Distribution.Text (display)
import Distribution.Verbosity (silent)
import Base
import Expression
import GHC
import Oracles.Dependencies (pkgDependencies)
import Predicate
import Distribution.Verbosity (silent)
import Distribution.Text (display)
import Distribution.Package (pkgVersion)
import Distribution.PackageDescription (packageDescription)
import qualified Distribution.PackageDescription as DP
ghcCabalPackageArgs :: Args
ghcCabalPackageArgs = stage0 ? package ghcCabal ? builder Ghc ? do
......
......@@ -2,13 +2,13 @@ module Settings.Packages.GhcPrim (ghcPrimPackageArgs) where
import GHC
import Oracles.Config.Flag
import Predicate
import Expression
ghcPrimPackageArgs :: Args
ghcPrimPackageArgs = package ghcPrim ? mconcat
[ builder GhcCabal ? arg "--flag=include-ghc-prim"
, builder (Cc CompileC) ?
(not <$> flag GccLt44) ?
, builder (Cc CompileC) ?
(not <$> flag GccLt44) ?
(not <$> flag GccIsClang) ?
input "//cbits/atomic.c" ? arg "-Wno-sync-nand" ]
input "//cbits/atomic.c" ? arg "-Wno-sync-nand" ]
module Settings.Packages.Ghci (ghciPackageArgs) where
import GHC