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

Clean up code, add comments.

parent 5603275f
module Base (
module Control.Applicative,
module Control.Monad.Extra,
module Control.Monad.Reader,
module Data.Char,
module Data.Function,
module Data.List,
......@@ -22,6 +23,7 @@ module Base (
import Control.Applicative
import Control.Monad.Extra
import Control.Monad.Reader
import Data.Char
import Data.Function
import Data.List
......
{-# LANGUAGE FlexibleInstances #-}
module Expression (
module Base,
module Control.Monad.Reader,
module Builder,
module Package,
module Stage,
module Way,
Expr, DiffExpr, fromDiffExpr,
Predicate, (?), applyPredicate,
Args, Ways, Packages,
Predicate, (?), applyPredicate, Args, Ways, Packages,
Target, PartialTarget (..), fromPartial, fullTarget, fullTargetWithWay,
apply, append, appendM, remove,
appendSub, appendSubD, filterSub, removeSub,
apply, append, arg, remove, appendSub, appendSubD, filterSub, removeSub,
interpret, interpretPartial, interpretWithStage, interpretDiff,
getStage, getPackage, getBuilder, getFiles, getFile,
getSources, getSource, getWay
getStage, getPackage, getBuilder, getFiles, getSources, getWay,
getSource, getFile
) where
import Base
import Builder
import Control.Monad.Reader
import Package
import Stage
import Target
......@@ -72,6 +68,10 @@ applyPredicate predicate expr = do
bool <- predicate
if bool then expr else return mempty
-- Add a single String argument to Args
arg :: String -> Args
arg = append . return
-- A convenient operator for predicate application
class PredicateLike a where
(?) :: Monoid m => a -> Expr m -> Expr m
......@@ -87,10 +87,6 @@ instance PredicateLike Bool where
instance PredicateLike (Action Bool) where
(?) = applyPredicate . lift
-- A monadic version of append
appendM :: Monoid a => Action a -> DiffExpr a
appendM = (append =<<) . lift
-- appendSub appends a list of sub-arguments to all arguments starting with a
-- given prefix. If there is no argument with such prefix then a new argument
-- of the form 'prefix=listOfSubarguments' is appended to the expression.
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.ArgsHash (
checkArgsHash, argsHashOracle
) where
module Oracles.ArgsHash (checkArgsHash, argsHashOracle) where
import Target
import Expression
import Settings
import Settings.Args
import Target
newtype ArgsHashKey = ArgsHashKey Target
deriving (Show, Eq, Typeable, Binary, Hashable, NFData)
......
module Oracles.Config.Flag (
Flag (..), flag,
Flag (..), flag, getFlag,
crossCompiling, gccIsClang, gccGe46,
platformSupportsSharedLibs, ghcWithSMP, ghcWithNativeCodeGen
) where
......@@ -8,24 +8,24 @@ import Base
import Oracles.Config
import Oracles.Config.Setting
data Flag = GccIsClang
data Flag = CrossCompiling
| GccIsClang
| GccLt46
| CrossCompiling
| SupportsPackageKey
| GhcUnregisterised
| SolarisBrokenShld
| SplitObjectsBroken
| GhcUnregisterised
| SupportsPackageKey
flag :: Flag -> Action Bool
flag f = do
key <- return $ case f of
CrossCompiling -> "cross-compiling"
GccIsClang -> "gcc-is-clang"
GccLt46 -> "gcc-lt-46"
CrossCompiling -> "cross-compiling"
SupportsPackageKey -> "supports-package-key"
GhcUnregisterised -> "ghc-unregisterised"
SolarisBrokenShld -> "solaris-broken-shld"
SplitObjectsBroken -> "split-objects-broken"
GhcUnregisterised -> "ghc-unregisterised"
SupportsPackageKey -> "supports-package-key"
value <- askConfigWithDefault key . putError
$ "\nFlag '" ++ key ++ "' not set in configuration files."
unless (value == "YES" || value == "NO") . putError
......@@ -33,6 +33,9 @@ flag f = do
++ "' instead of 'YES' or 'NO'."
return $ value == "YES"
getFlag :: Flag -> ReaderT a Action Bool
getFlag = lift . flag
crossCompiling :: Action Bool
crossCompiling = flag CrossCompiling
......
module Oracles.Config.Setting (
Setting (..), SettingList (..),
setting, settingList,
setting, settingList, getSetting, getSettingList,
targetPlatform, targetPlatforms, targetOs, targetOss, notTargetOs,
targetArchs, windowsHost, notWindowsHost, ghcWithInterpreter,
ghcEnableTablesNextToCode, cmdLineLengthLimit
......@@ -54,6 +54,12 @@ settingList key = fmap words $ askConfig $ case key of
GmpIncludeDirs -> "gmp-include-dirs"
GmpLibDirs -> "gmp-lib-dirs"
getSetting :: Setting -> ReaderT a Action String
getSetting = lift . setting
getSettingList :: SettingList -> ReaderT a Action [String]
getSettingList = lift . settingList
matchSetting :: Setting -> [String] -> Action Bool
matchSetting key values = do
value <- setting key
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.Dependencies (
dependencies,
dependenciesOracle
) where
module Oracles.Dependencies (dependencies, dependenciesOracle) where
import Base
import qualified Data.HashMap.Strict as Map
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.PackageData (
PackageData (..), PackageDataList (..),
pkgData, pkgDataList, packageDataOracle
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.PackageDeps (
packageDeps,
packageDepsOracle
) where
module Oracles.PackageDeps (packageDeps, packageDepsOracle) where
import Base
import Package
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.WindowsRoot (
windowsRoot, windowsRootOracle
) where
module Oracles.WindowsRoot (windowsRoot, windowsRootOracle) where
import Base
......
module Predicates (
module GHC,
module Oracles.Config.Flag,
module Oracles.Config.Setting,
stage, package, builder, stagedBuilder, file, way,
stage0, stage1, stage2, notStage, notStage0,
registerPackage, splitObjects
stage0, stage1, stage2, notStage0, registerPackage, splitObjects
) where
import Expression
import GHC
import Oracles
import Oracles.Config.Flag
import Oracles.Config.Setting
-- Basic predicates (see Switches.hs for derived predicates)
-- Basic predicates
stage :: Stage -> Predicate
stage s = liftM (s ==) getStage
stage s = fmap (s ==) getStage
package :: Package -> Predicate
package p = liftM (p ==) getPackage
package p = fmap (p ==) getPackage
-- For unstaged builders, e.g. GhcCabal
builder :: Builder -> Predicate
builder b = liftM (b ==) getBuilder
builder b = fmap (b ==) getBuilder
-- For staged builders, e.g. Ghc Stage
stagedBuilder :: (Stage -> Builder) -> Predicate
stagedBuilder sb = (builder . sb) =<< getStage
file :: FilePattern -> Predicate
file f = liftM (any (f ?==)) getFiles
file f = fmap (any (f ?==)) getFiles
way :: Way -> Predicate
way w = liftM (w ==) getWay
way w = fmap (w ==) getWay
-- Derived predicates
stage0 :: Predicate
......@@ -39,11 +42,8 @@ stage1 = stage Stage1
stage2 :: Predicate
stage2 = stage Stage2
notStage :: Stage -> Predicate
notStage = liftM not . stage
notStage0 :: Predicate
notStage0 = liftM not stage0
notStage0 = fmap not stage0
-- TODO: Actually, we don't register compiler in some circumstances -- fix.
registerPackage :: Predicate
......@@ -52,9 +52,9 @@ registerPackage = return True
splitObjects :: Predicate
splitObjects = do
goodStage <- notStage0 -- We don't split bootstrap (stage 0) packages
goodPkg <- liftM not $ package compiler -- We don't split compiler
broken <- lift $ flag SplitObjectsBroken
ghcUnreg <- lift $ flag GhcUnregisterised
goodPkg <- fmap not $ package compiler -- We don't split compiler
broken <- getFlag SplitObjectsBroken
ghcUnreg <- getFlag GhcUnregisterised
goodArch <- lift $ targetArchs [ "i386", "x86_64", "powerpc", "sparc" ]
goodOs <- lift $ targetOss [ "mingw32", "cygwin32", "linux", "darwin"
, "solaris2", "freebsd", "dragonfly"
......
......@@ -17,16 +17,16 @@ generateTargets = action $ do
libName <- interpretPartial target $ getPkgData LibName
needGhciLib <- interpretPartial target $ getPkgData BuildGhciLib
needHaddock <- interpretPartial target buildHaddock
let ghciLib = [ buildPath -/- "HS" ++ libName <.> "o"
| needGhciLib == "YES" && stage /= Stage0 ]
haddock = [ pkgHaddockFile pkg | needHaddock ]
ways <- interpretPartial target getWays
ways <- interpretPartial target getWays
let ghciLib = buildPath -/- "HS" ++ libName <.> "o"
haddock = pkgHaddockFile pkg
libs <- forM ways $ \way -> do
extension <- libsuf way
return $ buildPath -/- "libHS" ++ libName <.> extension
return $ ghciLib ++ libs ++ haddock
return $ [ ghciLib | needGhciLib == "YES" && stage == Stage1 ]
++ [ haddock | needHaddock && stage == Stage1 ]
++ libs
need $ reverse targets
......
......@@ -5,6 +5,7 @@ import Oracles
import Oracles.ArgsHash
import Settings
import Settings.Args
import Settings.Builders.Ar
import qualified Target
-- Build a given target using an appropriate builder and acquiring necessary
......
......@@ -31,4 +31,3 @@ buildPackageDependencies _ target @ (PartialTarget stage pkg) =
cDeps <- fmap concat $ mapM readFile' cDepFiles
hDeps <- readFile' hDepFile
writeFileChanged file $ cDeps ++ hDeps
......@@ -10,11 +10,10 @@ import Settings
-- All of them go into the 'doc' subdirectory. Pedantically tracking all built
-- files in the Shake databases seems fragile and unnecesarry.
buildPackageDocumentation :: Resources -> PartialTarget -> Rules ()
buildPackageDocumentation _ target @ (PartialTarget stage pkg) =
buildPackageDocumentation _ target @ (PartialTarget _ pkg) =
let cabalFile = pkgCabalFile pkg
haddockFile = pkgHaddockFile pkg
in when (stage == Stage1) $ do
in do
haddockFile %> \file -> do
whenM (specified HsColour) $ do
need [cabalFile]
......@@ -27,13 +26,6 @@ buildPackageDocumentation _ target @ (PartialTarget stage pkg) =
let haddockWay = if dynamicGhcPrograms then dynamic else vanilla
build $ fullTargetWithWay target Haddock haddockWay srcs [file]
-- $$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_DEPS =
-- $$(foreach n,$$($1_$2_DEPS)
-- ,$$($$n_HADDOCK_FILE) $$($$n_dist-install_$$(HADDOCK_WAY)_LIB))
-- $$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_FILE) :
-- $$$$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_DEPS) | $$$$(dir $$$$@)/.
-- # Make the haddocking depend on the library .a file, to ensure
-- # that we wait until the library is fully built before we haddock it
-- $$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_FILE) : $$($1_$2_$$(HADDOCK_WAY)_LIB)
......
......@@ -2,12 +2,78 @@ module Settings (
module Settings.Packages,
module Settings.TargetDirectory,
module Settings.User,
module Settings.Util,
module Settings.Ways
module Settings.Ways,
getPkgData, getPkgDataList,
getPackagePath, getTargetDirectory, getTargetPath, getPackageSources,
) where
import Expression
import Oracles
import Settings.Packages
import Settings.TargetDirectory
import Settings.User
import Settings.Util
import Settings.Ways
getPackagePath :: Expr FilePath
getPackagePath = liftM pkgPath getPackage
getTargetDirectory :: Expr FilePath
getTargetDirectory = liftM2 targetDirectory getStage getPackage
getTargetPath :: Expr FilePath
getTargetPath = liftM2 targetPath getStage getPackage
getPkgData :: (FilePath -> PackageData) -> Expr String
getPkgData key = lift . pkgData . key =<< getTargetPath
getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
getPkgDataList key = lift . pkgDataList . key =<< getTargetPath
-- Find all Haskell source files for the current target. TODO: simplify.
getPackageSources :: Expr [FilePath]
getPackageSources = do
path <- getTargetPath
packagePath <- getPackagePath
srcDirs <- getPkgDataList SrcDirs
let buildPath = path -/- "build"
dirs = (buildPath -/- "autogen") : map (packagePath -/-) srcDirs
(foundSources, missingSources) <- findModuleFiles dirs "*hs"
-- Generated source files live in buildPath and have extension "hs"
let generatedSources = [ buildPath -/- s <.> "hs" | s <- missingSources ]
return $ foundSources ++ generatedSources
-- findModuleFiles scans a list of given directories and finds files matching a
-- given extension pattern (e.g., "*hs") that correspond to modules of the
-- currently built package. Missing module files are returned in a separate
-- list. The returned pair contains the following:
-- * a list of found module files, with paths being relative to one of given
-- directories, e.g. "codeGen/CodeGen/Platform.hs" for the compiler package.
-- * a list of module files that have not been found, with paths being relative
-- to the module directory, e.g. "CodeGen/Platform", and with no extension.
findModuleFiles :: [FilePath] -> FilePattern -> Expr ([FilePath], [FilePath])
findModuleFiles dirs extension = do
modules <- getPkgDataList Modules
let decodedMods = sort . map decodeModule $ modules
modDirFiles = map (bimap head sort . unzip)
. groupBy ((==) `on` fst) $ decodedMods
matchExtension = (?==) ("*" <.> extension)
result <- lift . fmap concat . forM dirs $ \dir -> do
todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
forM todo $ \(mDir, mFiles) -> do
let fullDir = dir -/- mDir
files <- fmap (filter matchExtension) $ getDirectoryContents fullDir
let cmp fe f = compare (dropExtension fe) f
found = intersectOrd cmp files mFiles
return (map (fullDir -/-) found, (mDir, map dropExtension found))
let foundFiles = concatMap fst result
foundMods = [ (d, f) | (d, fs) <- map snd result, f <- fs ]
missingMods = decodedMods `minusOrd` sort foundMods
missingFiles = map (uncurry (-/-)) missingMods
return (foundFiles, missingFiles)
module Settings.Args (args, getArgs, arPersistentArgsCount) where
module Settings.Args (getArgs) where
import Expression
import Settings
import Settings.User
import Settings.Builders.Ar
import Settings.Builders.Ld
import Settings.Builders.Ghc
......@@ -10,11 +10,8 @@ import Settings.Builders.GhcPkg
import Settings.Builders.Haddock
import Settings.Builders.GhcCabal
args :: Args
args = defaultArgs <> userArgs
getArgs :: Expr [String]
getArgs = fromDiffExpr args
getArgs = fromDiffExpr $ defaultArgs <> userArgs
-- TODO: add all other settings
-- TODO: add src-hc-args = -H32m -O
......
......@@ -3,7 +3,6 @@ module Settings.Builders.Ar (arArgs, arPersistentArgsCount) where
import Builder
import Expression
import Predicates (builder)
import Settings.Util
arArgs :: Args
arArgs = builder Ar ? do
......
module Settings.Builders.Gcc (gccArgs, gccMArgs) where
import Expression
import Oracles
import Predicates (stagedBuilder)
import Oracles.PackageData
import Settings.Util
import Settings
-- TODO: check code duplication
gccArgs :: Args
gccArgs = stagedBuilder Gcc ? do
file <- getFile
src <- getSource
ccArgs <- getPkgDataList CcArgs
mconcat [ append ccArgs
, includeGccArgs
file <- getFile
src <- getSource
mconcat [ commonGccArgs
, arg "-c"
, arg src
, arg "-o"
......@@ -21,13 +18,11 @@ gccArgs = stagedBuilder Gcc ? do
-- TODO: handle custom $1_$2_MKDEPENDC_OPTS and
gccMArgs :: Args
gccMArgs = stagedBuilder GccM ? do
file <- getFile
src <- getSource
ccArgs <- getPkgDataList CcArgs
file <- getFile
src <- getSource
mconcat [ arg "-E"
, arg "-MM"
, append ccArgs -- TODO: remove? any other flags?
, includeGccArgs
, commonGccArgs
, arg "-MF"
, arg file
, arg "-MT"
......@@ -36,12 +31,13 @@ gccMArgs = stagedBuilder GccM ? do
, arg "c"
, arg src ]
includeGccArgs :: Args
includeGccArgs = do
pkg <- getPackage
path <- getTargetPath
iDirs <- getPkgDataList IncludeDirs
dDirs <- getPkgDataList DepIncludeDirs
mconcat
[ arg $ "-I" ++ path -/- "build/autogen"
, append . map (\dir -> "-I" ++ pkgPath pkg -/- dir) $ iDirs ++ dDirs ]
commonGccArgs :: Args
commonGccArgs = do
pkg <- getPackage
path <- getTargetPath
iDirs <- getPkgDataList IncludeDirs
dDirs <- getPkgDataList DepIncludeDirs
ccArgs <- getPkgDataList CcArgs
mconcat [ append ccArgs
, arg $ "-I" ++ path -/- "build/autogen"
, append [ "-I" ++ pkgPath pkg -/- dir | dir <- iDirs ++ dDirs ]]
module Settings.Builders.Ghc (ghcArgs, ghcMArgs, commonGhcArgs) where
import Expression
import Predicates (stagedBuilder, splitObjects, stage0)
import Oracles
import Predicates (stagedBuilder, splitObjects, stage0)
import Settings
-- TODO: add support for -dyno
......@@ -33,9 +33,9 @@ ghcMArgs = stagedBuilder GhcM ? do
commonGhcArgs :: Args
commonGhcArgs = do
way <- getWay
path <- getTargetPath
hsArgs <- getPkgDataList HsArgs
cppArgs <- getPkgDataList CppArgs
path <- getTargetPath
let buildPath = path -/- "build"
mconcat [ arg "-hisuf", arg $ hisuf way
, arg "-osuf" , arg $ osuf way
......
module Settings.Builders.GhcCabal (
cabalArgs, ghcCabalHsColourArgs,
bootPackageDbArgs, customPackageArgs
cabalArgs, ghcCabalHsColourArgs, bootPackageDbArgs, customPackageArgs
) where
import Way
import Stage
import Builder
import Package
import Expression
import Predicates
import Oracles
import Settings
cabalArgs :: Args
......@@ -73,11 +67,10 @@ configureArgs = do
, conf "LDFLAGS" ldFlags
, conf "CPPFLAGS" cppFlags
, appendSubD "--gcc-options" $ cFlags <> ldFlags
, conf "--with-iconv-includes" $ argSettingList IconvIncludeDirs
, conf "--with-iconv-libraries" $ argSettingList IconvLibDirs
, conf "--with-gmp-includes" $ argSettingList GmpIncludeDirs
, conf "--with-gmp-libraries" $ argSettingList GmpLibDirs
-- TODO: why TargetPlatformFull and not host?
, conf "--with-iconv-includes" $ argSettingList IconvIncludeDirs
, conf "--with-iconv-libraries" $ argSettingList IconvLibDirs
, conf "--with-gmp-includes" $ argSettingList GmpIncludeDirs
, conf "--with-gmp-libraries" $ argSettingList GmpLibDirs
, crossCompiling ? (conf "--host" $ argSetting TargetPlatformFull)
, conf "--with-cc" $ argStagedBuilderPath Gcc ]
......@@ -190,3 +183,27 @@ with b = specified b ? do
withStaged :: (Stage -> Builder) -> Args
withStaged sb = (with . sb) =<< getStage
argM :: Action String -> Args
argM = (arg =<<) . lift
argSetting :: Setting -> Args
argSetting = argM . setting
argSettingList :: SettingList -> Args
argSettingList = (append =<<) . lift . settingList
argStagedSettingList :: (Stage -> SettingList) -> Args
argStagedSettingList ss = (argSettingList . ss) =<< getStage
argStagedBuilderPath :: (Stage -> Builder) -> Args
argStagedBuilderPath sb = (argM . builderPath . sb) =<< getStage
-- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
appendCcArgs :: [String] -> Args
appendCcArgs xs = do
mconcat [ stagedBuilder Gcc ? append xs
, stagedBuilder GccM ? append xs
, builder GhcCabal ? appendSub "--configure-option=CFLAGS" xs
, builder GhcCabal ? appendSub "--gcc-options" xs ]
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