Commit 0fe624fb authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add Simplify instances for PG and Predicate.

parent 79ad8ee4
......@@ -10,13 +10,14 @@ module Expression.Base (
FilePaths,
Ways,
project,
arg, args, argsOrdered, argBuildPath, argBuildDir,
arg, args, argPath, argsOrdered, argBuildPath, argBuildDir,
argInput, argOutput,
argConfig, argStagedConfig, argBuilderPath, argStagedBuilderPath,
argWithBuilder, argWithStagedBuilder,
argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
argIncludeDirs, argDepIncludeDirs,
argConcat, argConcatPath, argConcatSpace, argPairs, argPrefix,
argConcat, argConcatPath, argConcatSpace,
argPairs, argPrefix, argPrefixPath,
argBootPkgConstraints,
setPackage, setBuilder, setBuilderFamily, setStage, setWay,
setFile, setConfig
......@@ -24,6 +25,7 @@ module Expression.Base (
import Base hiding (arg, args, Args)
import Ways
import Util
import Package (Package)
import Oracles.Builder
import Expression.PG
......@@ -56,6 +58,10 @@ type FilePaths = BuildExpression FilePath
arg :: String -> Settings
arg = return . Plain
-- A single FilePath argument
argPath :: FilePath -> Settings
argPath = return . Plain . unifyPath
-- A set of arguments (unordered)
args :: [String] -> Settings
args = msum . map arg
......@@ -156,8 +162,8 @@ argPrefix :: String -> Settings -> Settings
argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
-- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
argPaths :: String -> Settings -> Settings
argPaths prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
argPrefixPath :: String -> Settings -> Settings
argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
-- Partially evaluate Settings using a truth-teller (compute a 'projection')
project :: (BuildVariable -> Maybe Bool) -> Settings -> Settings
......
......@@ -4,7 +4,7 @@ module Expression.Build (
BuildVariable (..),
BuildPredicate (..),
BuildExpression (..),
evaluate, tellTruth,
evaluate, simplify, tellTruth,
linearise, (|>), msum, mproduct, fromList, fromOrderedList,
packages, package, matchPackage,
builders, builder, matchBuilder, matchBuilderFamily,
......@@ -32,6 +32,7 @@ data BuildVariable = PackageVariable Package
| WayVariable Way
| FileVariable FilePattern
| ConfigVariable String String -- from config files
deriving (Show, Eq)
-- A datatype for build predicates
data BuildPredicate
......@@ -40,6 +41,19 @@ data BuildPredicate
| Not BuildPredicate -- Negation
| And BuildPredicate BuildPredicate -- Conjunction
| Or BuildPredicate BuildPredicate -- Disjunction
deriving Eq -- TODO: create a proper Eq instance (use BDDs?)
instance Show BuildPredicate where
showsPrec _ (Evaluated bool) = shows bool
showsPrec _ (Unevaluated var) = shows var
showsPrec d (Or p q) =
showParen (d > 0) $ shows p . showString " \\/ " . shows q
showsPrec d (And p q) =
showParen (d > 1) $ showsPrec 1 p . showString " /\\ " . showsPrec 1 q
showsPrec d (Not p) = showChar '!' . showsPrec 2 p
instance Predicate BuildPredicate where
type Variable BuildPredicate = BuildVariable
......@@ -71,23 +85,36 @@ evaluate t (Or p q) = Or (evaluate t p) (evaluate t q)
-- Nothing if the predicate cannot be evaluated due to remaining unevaluated
-- variables.
tellTruth :: BuildPredicate -> Maybe Bool
tellTruth (Evaluated bool) = Just bool
tellTruth (Unevaluated _) = Nothing
tellTruth (Not p) = not <$> tellTruth p
tellTruth (And p q)
| (p' == Just False) || (q' == Just False) = Just False
| (p' == Just True ) && (q' == Just True ) = Just True
| otherwise = Nothing
where
p' = tellTruth p
q' = tellTruth q
tellTruth (Or p q)
| (p' == Just True ) || (q' == Just True ) = Just True
| (p' == Just False) && (q' == Just False) = Just False
| otherwise = Nothing
where
p' = tellTruth p
q' = tellTruth q
tellTruth p = case simplify p of
Evaluated bool -> Just bool
_ -> Nothing
-- Simplify the predicate by constant propagation
instance Simplify BuildPredicate where
simplify p @ (Evaluated _) = p
simplify p @ (Unevaluated _) = p
simplify (Not p) = case p' of
Evaluated bool -> Evaluated (not bool)
_ -> Not p'
where p' = simplify p
simplify (And p q)
| p' == false = false
| q' == false = false
| p' == true = q'
| q' == true = p'
| otherwise = And p' q'
where
p' = simplify p
q' = simplify q
simplify (Or p q)
| p' == true = true
| q' == true = true
| p' == false = q'
| q' == false = p'
| otherwise = Or p' q'
where
p' = simplify p
q' = simplify q
-- Linearise a build expression into a list. Returns Nothing if the given
-- expression cannot be uniquely evaluated due to remaining variables.
......
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
module Expression.PG (
module Expression.Simplify,
module Expression.Predicate,
PG (..), (|>), (?), (??), whenExists,
PG (..),
(|>), (?), (??), whenExists,
msum, mproduct,
fromList, fromOrderedList
) where
import Expression.Simplify
import Data.Functor
import Control.Monad
import Control.Applicative
......@@ -20,6 +23,7 @@ data PG p v = Epsilon
| Overlay (PG p v) (PG p v)
| Sequence (PG p v) (PG p v)
| Condition p (PG p v)
deriving Eq -- TODO: create a proper Eq instance
instance Functor (PG p) where
fmap = liftM
......@@ -85,3 +89,45 @@ whenExists a (Condition x r) = x && whenExists a r
--mapP f (Overlay l r) = Overlay (mapP f l) (mapP f r)
--mapP f (Sequence l r) = Sequence (mapP f l) (mapP f r)
--mapP f (Condition x r) = Condition (f x ) (mapP f r)
instance (Show p, Show v) => Show (PG p v) where
showsPrec _ Epsilon = showString "()"
showsPrec _ (Vertex v) = shows v
showsPrec d (Overlay l r) =
showParen (d > 0) $ shows l . showChar ' ' . shows r
showsPrec d (Sequence l r) =
showParen (d > 1) $ showsPrec 1 l . showString " -> " . showsPrec 1 r
showsPrec d (Condition l r) =
showChar '[' . shows l . showChar ']' . showsPrec 2 r
instance (Simplify p, Predicate p, Eq p, Eq v) => Simplify (PG p v) where
simplify Epsilon = Epsilon
simplify v @ (Vertex _) = v
simplify (Overlay l r)
| l' == Epsilon = r'
| r' == Epsilon = l'
| l' == r' = l'
| otherwise = Overlay l' r'
where
l' = simplify l
r' = simplify r
simplify (Sequence l r)
| l' == Epsilon = r'
| r' == Epsilon = l'
| otherwise = Sequence l' r'
where
l' = simplify l
r' = simplify r
simplify (Condition l r)
| l' == true = r'
| l' == false = Epsilon
| r' == Epsilon = Epsilon
| otherwise = Condition l' r'
where
l' = simplify l
r' = simplify r
module Expression.Simplify (
Simplify (..)
) where
class Simplify a where
simplify :: a -> a
......@@ -4,9 +4,15 @@ import Oracles
import Package
import Targets
import Settings
import Expression.Simplify
main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do
oracleRules
autoconfRules
configureRules
--packageRules
action $ do
putNormal $ "targetPackages = " ++ show (simplify targetPackages)
putNormal $ "\ntargetWays = " ++ show (simplify targetWays)
......@@ -11,6 +11,9 @@ data Package = Package
pkgCabal :: FilePath -- "deepseq.cabal", "Cabal.cabal"
}
instance Show Package where
show = pkgName
instance Eq Package where
(==) = (==) `on` pkgName
......
......@@ -17,7 +17,8 @@ validating = false
packageSettings :: Settings
packageSettings = msum
[ args ["-hide-all-packages", "-no-user-package-db", "-include-pkg-deps"]
, stage Stage0 ? arg "-package-db libraries/bootstrapping.conf"
, stage Stage0 ?
(arg "-package-db" |> argPath "libraries/bootstrapping.conf")
, supportsPackageKey && notStage Stage0 ??
( argPairs "-this-package-key" argPackageKey <|>
argPairs "-package-key" argPackageDepKeys
......@@ -39,7 +40,7 @@ librarySettings ways = msum
ccSettings :: Settings
ccSettings = msum
[ package integerLibrary ? arg "-Ilibraries/integer-gmp2/gmp"
[ package integerLibrary ? argPath "-Ilibraries/integer-gmp2/gmp"
, builder GhcCabal ? argStagedConfig "conf-cc-args"
, validating ? msum
[ not (builder GhcCabal) ? arg "-Werror"
......@@ -61,18 +62,18 @@ configureSettings =
. argConcatSpace
in
msum [ conf "CFLAGS" ccSettings
, conf "LDFLAGS" ldSettings
, conf "CPPFLAGS" cppSettings
, argPrefix "--gcc-options=" $
argConcatSpace (ccSettings <|> ldSettings)
, conf "--with-iconv-includes" (argConfig "iconv-include-dirs")
, conf "--with-iconv-libraries" (argConfig "iconv-lib-dirs")
, conf "--with-gmp-includes" (argConfig "gmp-include-dirs")
, conf "--with-gmp-libraries" (argConfig "gmp-lib-dirs")
-- TODO: why TargetPlatformFull and not host?
, crossCompiling ?
conf "--host" (argConfig "target-platform-full")
, conf "--with-cc" (argStagedBuilderPath Gcc) ]
, conf "LDFLAGS" ldSettings
, conf "CPPFLAGS" cppSettings
, argPrefix "--gcc-options=" $
argConcatSpace (ccSettings <|> ldSettings)
, conf "--with-iconv-includes" (argConfig "iconv-include-dirs")
, conf "--with-iconv-libraries" (argConfig "iconv-lib-dirs")
, conf "--with-gmp-includes" (argConfig "gmp-include-dirs")
, conf "--with-gmp-libraries" (argConfig "gmp-lib-dirs")
-- TODO: why TargetPlatformFull and not host?
, crossCompiling ?
conf "--host" (argConfig "target-platform-full")
, conf "--with-cc" (argStagedBuilderPath Gcc) ]
-- this is a positional argument, hence:
-- * if it is empty, we need to emit one empty string argument
......@@ -89,15 +90,12 @@ customConfigureSettings = msum
arg "--configure-option=--with-intree-gmp"
]
-- bootPackageDb
bootPackageDbSettings :: Settings
bootPackageDbSettings =
stage Stage0 ?
argPrefix "--package-db="
(argConcatPath $
argConfig "ghc-source-path" |>
arg "libraries" |>
arg "bootstrapping.conf" )
(argConcatPath $ argConfig "ghc-source-path" |>
argPath "libraries/bootstrapping.conf")
cabalSettings :: Settings
cabalSettings =
......@@ -106,22 +104,21 @@ cabalSettings =
, arg "configure"
, argBuildPath
, argBuildDir
, dllSettings ]
|>
msum
[ argWithStagedBuilder Ghc -- TODO: used to be limited to max stage1 GHC
, argWithStagedBuilder GhcPkg
, customConfigureSettings
, stage Stage0 ? bootPackageDbSettings
, librarySettings targetWays
, configNonEmpty "hscolour" ? argWithBuilder HsColour -- TODO: more reuse
, configureSettings
, stage Stage0 ? argBootPkgConstraints
, argWithStagedBuilder Gcc
, notStage Stage0 ? argWithBuilder Ld
, argWithBuilder Ar
, argWithBuilder Alex
, argWithBuilder Happy ] -- TODO: reorder with's
, dllSettings
, msum
[ argWithStagedBuilder Ghc -- TODO: used to be limited to max stage1 GHC
, argWithStagedBuilder GhcPkg
, customConfigureSettings
, stage Stage0 ? bootPackageDbSettings
, librarySettings targetWays
, configNonEmpty "hscolour" ? argWithBuilder HsColour -- TODO: more reuse
, configureSettings
, stage Stage0 ? argBootPkgConstraints
, argWithStagedBuilder Gcc
, notStage Stage0 ? argWithBuilder Ld
, argWithBuilder Ar
, argWithBuilder Alex
, argWithBuilder Happy ]] -- TODO: reorder with's
ghcPkgSettings :: Settings
ghcPkgSettings =
......
......@@ -37,6 +37,9 @@ data Way = Way
units :: [WayUnit] -- e.g., [Threaded, Profiling]
}
instance Show Way where
show = tag
instance Eq Way where
-- The tag is fully determined by the units
a == b = units a == units b
......
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