diff --git a/hadrian/completion.sh b/hadrian/completion.sh
new file mode 100755
index 0000000000000000000000000000000000000000..589fdf57958cbc9938506d23359c307b259da274
--- /dev/null
+++ b/hadrian/completion.sh
@@ -0,0 +1,7 @@
+#!/usr/bin/env bash
+
+hadrian=$(cd hadrian; cabal new-exec which hadrian; cd ..)
+all_settings=$($hadrian autocomplete --complete-setting="$@" --quiet)
+
+complete -W "$all_settings" hadrian/build.sh
+complete -W "$all_settings" hadrian/build.cabal.sh
diff --git a/hadrian/doc/user-settings.md b/hadrian/doc/user-settings.md
index 84298684c4af7aa3cd28eff33a686fc0d27f7fdd..6a1d5be847ec6f898dac30f9a09d52d26f8847e8 100644
--- a/hadrian/doc/user-settings.md
+++ b/hadrian/doc/user-settings.md
@@ -1,11 +1,15 @@
-# User settings
+# Settings
-You can customise Hadrian by copying the file `hadrian/src/UserSettings.hs` to
-`hadrian/UserSettings.hs` and overriding the default build settings (if you don't
-copy the file your changes will be tracked by `git` and you can accidentally commit
-them). Here we document currently supported settings.
+You can customise Hadrian in two ways:
-## Build flavour
+- by copying the file `hadrian/src/UserSettings.hs` to `hadrian/UserSettings.hs`
+ and overriding the default build settings (if you don't
+ copy the file your changes will be tracked by `git` and you can accidentally commit
+ them). Here we document currently supported settings.
+
+## The `UserSettings` module
+
+### Build flavour
Build _flavour_ is a collection of build settings that fully define a GHC build
(see `src/Flavour.hs`):
@@ -103,7 +107,7 @@ patterns such as `"//Prelude.*"` can be used when matching input and output file
where `//` matches an arbitrary number of path components and `*` matches an entire
path component, excluding any separators.
-### Enabling -Werror
+#### Enabling -Werror
It is useful to enable `-Werror` when building GHC as this setting is
used in the CI to ensure a warning free build. The `werror` function can be
@@ -114,7 +118,7 @@ devel2WerrorFlavour :: Flavour
devel2WerrorFlavour = werror (developmentFlavour Stage2)
```
-### Linking GHC against the debugged RTS
+#### Linking GHC against the debugged RTS
What was previously achieved by having `GhcDebugged=YES` in `mk/build.mk` can
be done by defining a custom flavour in the user settings file, one that
@@ -129,7 +133,7 @@ Running `build --flavour=dbg` will build a `quick`-flavoured GHC and link
GHC, iserv, iserv-proxy and remote-iserv against the debugged RTS, by passing
`-debug` to the commands that link those executables.
-## Packages
+### Packages
Users can add and remove packages from particular build stages. As an example,
below we add package `base` to Stage0 and remove package `haskeline` from Stage1:
@@ -170,7 +174,7 @@ userFlavour :: Flavour
userFlavour = defaultFlavour { name = "user", integerLibrary = pure integerSimple }
```
-### Specifying the final stage to build
+#### Specifying the final stage to build
The `finalStage` variable can be set to indicate after which stage we should
stop the compilation pipeline. By default it is set to `Stage2` which indicates
@@ -185,7 +189,7 @@ Using this mechanism we can also build a `Stage3` compiler by setting
`finalStage = Stage3` or just a `Stage1` compiler by setting
`finalStage = Stage1`.
-## Build ways
+### Build ways
Packages can be built in a number of ways, such as `vanilla`, `profiling` (with
profiling information enabled), and many others as defined in `src/Way.hs`. You
@@ -212,7 +216,7 @@ noDynamicFlavour = defaultFlavour
, libraryWays = remove [dynamic] defaultLibraryWays }
```
-## Verbose command lines
+### Verbose command lines
By default Hadrian does not print full command lines during the build process
and instead prints short human readable digests for each executed command. You
@@ -247,7 +251,7 @@ verboseCommand = output "//rts/sm/*" &&^ way threaded
verboseCommand = return True
```
-## Documentation
+### Documentation
`Flavour`'s `ghcDocs :: Action DocTargets` field lets you
customize the "groups" of documentation targets that should
@@ -286,7 +290,7 @@ all of the documentation targets:
You can pass several `--docs=...` flags, Hadrian will combine
their effects.
-## Split sections
+### Split sections
You can build all or just a few packages with
[`-split-sections`][split-sections] by tweaking an existing
@@ -312,7 +316,7 @@ Changing `(const True)` to `(== base)` would only build `base` with
library with `-split-sections` (it is usually not worth using that
option with the `ghc` library).
-## Miscellaneous
+### Miscellaneous
Hadrian prints various progress info during the build. You can change the colours
used by default by overriding `buildProgressColour` and `successColour`:
@@ -337,4 +341,96 @@ Vivid Cyan
Extended "203"
```
+## `key = value` and `key += value` style settings
+
+One can alternatively supply settings from the command line or a
+`<build root>/hadrian.settings` file. Hadrian currently supports two
+"families" of settings:
+
+- `{stage0, ..., stage3, *}.(<package name> or *).ghc.{c, hs, link, deps, toolargs, *}.opts`
+- `{stage0, ..., stage3, *}.(<package name> or *).cc.{c, deps, *}.opts`
+
+For example, putting the following in a file at `_build/hadrian.settings`:
+
+``` make
+stage1.ghc-bin.ghc.link.opts += -eventlog
+*.base.ghc.*.opts += -v3
+```
+
+and running hadrian with the default build root (`_build`), would respectively
+link the stage 2 GHC executable (using the stage 1 GHC) with the `-eventlog`
+flag, so that stage 2 GHC supports producing eventlogs with `+RTS -l`, and use
+`-v3` on all GHC commands used to build anything related to `base`, whatever
+the stage.
+
+We could equivalently specify those settings on the command-line:
+
+``` sh
+$ hadrian/build.sh "stage1.ghc-bin.ghc.link.opts += -eventlog" \
+ "*.base.ghc.*.opts += -v3"
+```
+
+or specify some in `hadrian.settings` and some on the command-line.
+
+Here is an overview of the supported settings and how you can figure out
+the right names for them:
+
+- the stage slot, which comes first, can be filled with any of `stage0`,
+ `stage1`, `stage2`, `stage3` or `*`; any value but `*` will restrict the
+ setting update to targets built during the given stage, while `*` is taken
+ to mean "for any stage".
+- the package slot, which comes second, can be filled with any package name
+ that Hadrian knows about (all packages that are part of a GHC checkout),
+ or `*`, to respectively mean that the builder options are going to be updated
+ only when building the given package, or that the said options should be used
+ when building all known packages, if the Hadrian command ever gets them to be
+ built;
+- the third slot is the builder, `ghc` or `cc`, to refer to GHC commands or
+ C compiler commands;
+- the final slot is the builder mode, `{c, hs, link, deps, toolargs}`:
+
+ * `c` for commands that build C files with GHC
+ * `hs` for commands that compile Haskell modules with GHC
+ * `link` for GHC linking command
+ * `deps` for commands that figure out dependencies between Haskell modules
+ (with `ghc -M`)
+ * `toolargs` for GHC commands that are used to generate the right ghci
+ argument for `hadrian/ghci.sh` to work
+
+ for GHC and `{c, deps}`:
+
+ * `c` for commands that call the C compiler on some C files
+ * `deps` for commands that call the C compiler for figuring out
+ dependencies between C files
+
+ for the C compiler;
+- using a wildcard (`*`) ranges over all possible values for a given "slot";
+- `=` entirely overrides the arguments for a given builder in a given context,
+ with the value specified on the right hand side of `=`, while `+=` merely
+ extends the arguments that are to be emitted in the said context, with
+ the values supplied on the right hand side of `+=`.
+
+See `Note [Hadrian settings]` in `hadrian/src/Settings.hs` for explanations
+about the implementation and how the set of supported settings can be
+extended.
+
+### Tab completion
+
+Hadrian supports tab-completion for the key-value settings. This is implemented
+in `Rules.SimpleTargets.completionRule`, by exporting an `autocomplete` target
+that takes an (optional) argument, `--complete-setting=<some string>`, and
+prints on stdout all the setting keys that have the given string as a prefix.
+
+There is a `hadrian/completion.sh` script that makes use of this rule to
+install Bash completions for `hadrian/build.sh` and `hadrian/build.cabal.sh`.
+You can try it out by doing:
+
+``` sh
+$ source hadrian/completion.sh
+$ hadrian/build.sh <TAB>
+$ hadrian/build.sh stage1.ba<TAB>
+$ hadrian/build.sh "stage1.base.ghc.<TAB>
+$ hadrian/build.sh "*.*.ghc.*.opts += -v3" "stage0.ghc-bin.ghc.lin<TAB>
+```
+
[split-sections]: https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/phases.html#ghc-flag--split-sections
diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal
index 1e7287cb921c2fe9aa622001e2af70a137a05863..2c5781f196f2b968e4604d30d568a0f0528ce2dc 100644
--- a/hadrian/hadrian.cabal
+++ b/hadrian/hadrian.cabal
@@ -101,6 +101,7 @@ executable hadrian
, Settings.Flavours.Quickest
, Settings.Flavours.GhcInGhci
, Settings.Packages
+ , Settings.Parser
, Settings.Warnings
, Stage
, Target
diff --git a/hadrian/src/CommandLine.hs b/hadrian/src/CommandLine.hs
index 461898cdfdceb662b2ee1eeb0abd67856fcf851b..aad616f40a9b98a9c721cbe9200dcbfab1812bba 100644
--- a/hadrian/src/CommandLine.hs
+++ b/hadrian/src/CommandLine.hs
@@ -1,6 +1,6 @@
module CommandLine (
optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple,
- cmdProgressColour, cmdProgressInfo, cmdConfigure,
+ cmdProgressColour, cmdProgressInfo, cmdConfigure, cmdCompleteSetting,
cmdDocsArgs, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs
) where
@@ -10,8 +10,10 @@ import Data.List.Extra
import Development.Shake hiding (Normal)
import Flavour (DocTargets, DocTarget(..))
import Hadrian.Utilities hiding (buildRoot)
+import Settings.Parser
import System.Console.GetOpt
import System.Environment
+import qualified System.Directory as Directory
import qualified Data.Set as Set
@@ -27,7 +29,8 @@ data CommandLineArgs = CommandLineArgs
, progressInfo :: ProgressInfo
, buildRoot :: BuildRoot
, testArgs :: TestArgs
- , docTargets :: DocTargets }
+ , docTargets :: DocTargets
+ , completeStg :: Maybe String }
deriving (Eq, Show)
-- | Default values for 'CommandLineArgs'.
@@ -41,7 +44,8 @@ defaultCommandLineArgs = CommandLineArgs
, progressInfo = Brief
, buildRoot = BuildRoot "_build"
, testArgs = defaultTestArgs
- , docTargets = Set.fromList [minBound..maxBound] }
+ , docTargets = Set.fromList [minBound..maxBound]
+ , completeStg = Nothing }
-- | These arguments are used by the `test` target.
data TestArgs = TestArgs
@@ -199,6 +203,9 @@ readTestWay way =
let newWays = way : testWays (testArgs flags)
in flags { testArgs = (testArgs flags) {testWays = newWays} }
+readCompleteStg :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readCompleteStg ms = Right $ \flags -> flags { completeStg = ms }
+
readDocsArg :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readDocsArg ms = maybe (Left "Cannot parse docs argument") (Right . set) (go =<< ms)
@@ -263,18 +270,48 @@ optDescrs =
"A verbosity value between 0 and 5. 0 is silent, 4 and higher activates extra output."
, Option [] ["test-way"] (OptArg readTestWay "TEST_WAY")
"only run these ways"
- , Option ['a'] ["test-accept"] (NoArg readTestAccept) "Accept new output of tests" ]
+ , Option ['a'] ["test-accept"] (NoArg readTestAccept) "Accept new output of tests"
+ , Option [] ["complete-setting"] (OptArg readCompleteStg "SETTING")
+ "Setting key to autocomplete, for the 'autocomplete' target."
+ ]
-- | A type-indexed map containing Hadrian command line arguments to be passed
-- to Shake via 'shakeExtra'.
cmdLineArgsMap :: IO (Map.HashMap TypeRep Dynamic)
cmdLineArgsMap = do
- (opts, _, _) <- getOpt Permute optDescrs <$> getArgs
- let args = foldl (flip id) defaultCommandLineArgs (rights opts)
+ xs <- getArgs
+ let -- We split the arguments between the ones that look like
+ -- "k = v" or "k += v", in cliSettings, and the rest in
+ -- optArgs.
+ (optsArgs, cliSettings) = partitionKVs xs
+
+ -- We only use the arguments that don't look like setting
+ -- updates for parsing Hadrian and Shake flags/options.
+ (opts, _, _) = getOpt Permute optDescrs optsArgs
+ args = foldl (flip id) defaultCommandLineArgs (rights opts)
+
+ BuildRoot root = buildRoot args
+ settingsFile = root -/- "hadrian.settings"
+
+ -- We try to look at <root>/hadrian.settings, and if it exists
+ -- we read as many settings as we can from it, combining
+ -- them with the ones we got on the command line, in allSettings.
+ -- We then insert all those settings in the dynamic map, so that
+ -- the 'Settings.flavour' action can look them up and apply
+ -- all the relevant updates to the flavour that Hadrian is set
+ -- to run with.
+ settingsFileExists <- Directory.doesFileExist settingsFile
+ fileSettings <-
+ if settingsFileExists
+ then parseJustKVs . lines <$> readFile settingsFile
+ else return []
+ let allSettings = cliSettings ++ fileSettings
+
return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
$ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
$ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities
$ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest
+ $ insertExtra allSettings -- Accessed by Settings
$ insertExtra args Map.empty
cmdLineArgs :: Action CommandLineArgs
@@ -286,6 +323,9 @@ cmdConfigure = configure <$> cmdLineArgs
cmdFlavour :: Action (Maybe String)
cmdFlavour = flavour <$> cmdLineArgs
+cmdCompleteSetting :: Action (Maybe String)
+cmdCompleteSetting = completeStg <$> cmdLineArgs
+
lookupBuildRoot :: Map.HashMap TypeRep Dynamic -> BuildRoot
lookupBuildRoot = buildRoot . lookupExtra defaultCommandLineArgs
diff --git a/hadrian/src/Hadrian/BuildPath.hs b/hadrian/src/Hadrian/BuildPath.hs
index 6fa4b7f3837e8a2b320e59d4260a741d03d578f0..499897d1775d5cbe451097b3c507bbdc24de6612 100644
--- a/hadrian/src/Hadrian/BuildPath.hs
+++ b/hadrian/src/Hadrian/BuildPath.hs
@@ -15,11 +15,12 @@ import qualified Text.Parsec as Parsec
-- @a@, which represents that @something@, is instantiated with library-related
-- data types in @Rules.Library@ and with object/interface files related types
-- in @Rules.Compile@.
-data BuildPath a = BuildPath FilePath -- ^ > <build root>/
- Stage -- ^ > stage<N>/
- FilePath -- ^ > <path/to/pkg/from/ghc/root>/build/
- a -- ^ > whatever comes after 'build/'
- deriving (Eq, Show)
+data BuildPath a = BuildPath
+ { _buildPathRoot :: FilePath -- ^ @<build root>/@
+ , _buildPathStage :: Stage -- ^ @stage<N>/@
+ , _buildPathPkgPath :: FilePath -- ^ @<path/to/pkg/from/ghc/root>/build/@
+ , _buildPathTarget :: a -- ^ whatever comes after @build/@
+ } deriving (Eq, Show)
-- | Parse a build path under the given build root.
parseBuildPath
@@ -45,13 +46,12 @@ parseBuildPath root afterBuild = do
-- @a@, which represents that @something@, is instantiated with library-related
-- data types in @Rules.Library@ and with object/interface files related types
-- in @Rules.Compile@.
-data GhcPkgPath a
- = GhcPkgPath
- FilePath -- ^ > <build root>/
- Stage -- ^ > stage<N>/
- FilePath -- ^ > lib/<arch>-<os>-ghc-<ghc version>/
- a -- ^ > whatever comes after
- deriving (Eq, Show)
+data GhcPkgPath a = GhcPkgPath
+ { _ghcpkgPathRoot :: FilePath -- ^ @<build root>/@
+ , _ghcpkgPathStage :: Stage -- ^ @stage<N>/@
+ , _ghcpkgRegPath :: FilePath -- ^ @lib/<arch>-<os>-ghc-<ghc version>/@
+ , _ghcPkgObject :: a -- ^ whatever comes after
+ } deriving (Eq, Show)
-- | Parse a registered ghc-pkg path under the given build root.
parseGhcPkgPath
diff --git a/hadrian/src/Main.hs b/hadrian/src/Main.hs
index 63001fe53b569267c2e81c40beb4f60ac0cf5fd2..804144aeb1efb19b76496d235cf53851fae3d525 100644
--- a/hadrian/src/Main.hs
+++ b/hadrian/src/Main.hs
@@ -4,6 +4,7 @@ import System.Directory (getCurrentDirectory)
import Development.Shake
import Hadrian.Expression
import Hadrian.Utilities
+import Settings.Parser
import qualified Base
import qualified CommandLine
@@ -79,7 +80,8 @@ main = do
Rules.toolArgsTarget
shakeArgsWith options CommandLine.optDescrs $ \_ targets -> do
+ let targets' = removeKVs targets
Environment.setupEnvironment
- return . Just $ if null targets
+ return . Just $ if null targets'
then rules
- else want targets >> withoutActions rules
+ else want targets' >> withoutActions rules
diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs
index 240e08dcdc4e1a063fd4a83b1708b81c57363452..851ccc05c7c421c9dae5acf7e40173f0c938337b 100644
--- a/hadrian/src/Rules.hs
+++ b/hadrian/src/Rules.hs
@@ -153,6 +153,7 @@ packageRules = do
forM_ vanillaContexts Rules.Generate.generatePackageCode
Rules.SimpleTargets.simplePackageTargets
+ Rules.SimpleTargets.completionRule
buildRules :: Rules ()
buildRules = do
diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs
index b6acf566f7ef854eebb403b6330273447e9b6ce5..4275ab1fa2b923f67bf21450ef6fe84dcde95443 100644
--- a/hadrian/src/Rules/Register.hs
+++ b/hadrian/src/Rules/Register.hs
@@ -72,7 +72,7 @@ registerPackages :: [Context] -> Action ()
registerPackages ctxs = do
need =<< mapM pkgRegisteredLibraryFile ctxs
- -- | Dynamic RTS library files need symlinks (Rules.Rts.rtsRules).
+ -- Dynamic RTS library files need symlinks (Rules.Rts.rtsRules).
forM_ ctxs $ \ ctx -> when (package ctx == rts) $ do
ways <- interpretInContext ctx (getLibraryWays <> getRtsWays)
needRtsSymLinks (stage ctx) ways
diff --git a/hadrian/src/Rules/SimpleTargets.hs b/hadrian/src/Rules/SimpleTargets.hs
index d0050431645ac7214302de89dba970fb9b33543e..1ce341866572fb38d6d9bb0ec5947bd2ba0bd838 100644
--- a/hadrian/src/Rules/SimpleTargets.hs
+++ b/hadrian/src/Rules/SimpleTargets.hs
@@ -1,6 +1,10 @@
-module Rules.SimpleTargets (simplePackageTargets) where
+module Rules.SimpleTargets
+ ( simplePackageTargets
+ , completionRule
+ ) where
import Base
+import CommandLine
import Context
import Packages
import Settings
@@ -47,3 +51,18 @@ getProgramPath Stage0 _ =
error ("Cannot build a stage 0 executable target: " ++
"it is the boot compiler's toolchain")
getProgramPath stage pkg = programPath (vanillaContext (pred stage) pkg)
+
+
+-- | A phony @autocomplete@ rule that prints all valid setting keys
+-- completions of the value specified in the @--complete-setting=...@ flag,
+-- or simply all valid setting keys if no such argument is passed to Hadrian.
+--
+-- It is based on the 'completeSetting' function, from the "Settings" module.
+completionRule :: Rules ()
+completionRule =
+ "autocomplete" ~> do
+ partialStr <- fromMaybe "" <$> cmdCompleteSetting
+ case completeSetting (splitOn "." partialStr) of
+ [] -> fail $ "No valid completion found for " ++ partialStr
+ cs -> forM_ cs $ \ks ->
+ liftIO . putStrLn $ intercalate "." ks
diff --git a/hadrian/src/Settings.hs b/hadrian/src/Settings.hs
index d3096e7987db1b445c07292ed9ac165b2d96a70b..0548bccfae1225f92b8751fb24ced346d90102c9 100755
--- a/hadrian/src/Settings.hs
+++ b/hadrian/src/Settings.hs
@@ -1,13 +1,15 @@
module Settings (
getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
findPackageByName, unsafeFindPackageByName, unsafeFindPackageByPath,
- isLibrary, stagePackages, programContext, getIntegerPackage
+ isLibrary, stagePackages, programContext, getIntegerPackage,
+ completeSetting
) where
import CommandLine
import Expression
import Flavour
import Packages
+import Settings.Parser
import UserSettings (userFlavours, userPackages, userDefaultFlavour)
import {-# SOURCE #-} Settings.Default
@@ -21,6 +23,9 @@ import Settings.Flavours.Quickest
import Settings.Flavours.QuickCross
import Settings.Flavours.GhcInGhci
+import Control.Monad.Except
+import Data.Either
+
getArgs :: Args
getArgs = expr flavour >>= args
@@ -43,12 +48,22 @@ hadrianFlavours =
, performanceLlvmFlavour, profiledLlvmFlavour, quickLlvmFlavour
, ghcInGhciFlavour ]
+-- | This action looks up a flavour with the name given on the
+-- command line with @--flavour@, defaulting to 'userDefaultFlavour'
+-- when no explicit @--flavour@ is passed. It then applies any
+-- potential setting update specified on the command line or in a
+-- <build root>/hadrian.settings file, using @k = v@ or @k += v@ style
+-- syntax. See Note [Hadrian settings] at the bottom of this file.
flavour :: Action Flavour
flavour = do
flavourName <- fromMaybe userDefaultFlavour <$> cmdFlavour
+ kvs <- userSetting ([] :: [KeyVal])
let unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
- flavours = hadrianFlavours ++ userFlavours
- return $ fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
+ flavours = hadrianFlavours ++ userFlavours
+ (_settingErrs, tweak) = applySettings kvs
+
+ return $ maybe unknownFlavour tweak $
+ find ((== flavourName) . name) flavours
getIntegerPackage :: Expr Package
getIntegerPackage = expr (integerLibrary =<< flavour)
@@ -88,3 +103,194 @@ unsafeFindPackageByPath :: FilePath -> Package
unsafeFindPackageByPath path = err $ find (\pkg -> pkgPath pkg == path) knownPackages
where
err = fromMaybe $ error ("findPackageByPath: No package for path " ++ path)
+
+-- * CLI and <root>/hadrian.settings options
+
+{-
+Note [Hadrian settings]
+~~~~~~~~~~~~~~~~~~~~~~~
+
+Hadrian lets one customize GHC builds through the UserSettings module,
+where Hadrian users can override existing 'Flavour's or create entirely
+new ones, overriding/extending the options passed to some builder
+building the RTS in more ways and much more.
+
+It now also offers a more "old-school" interface, in the form of
+@foo.bar.baz = v@ or @foo.bar.baz += v@ expressions, that one can
+pass on the command line that invokes hadrian:
+
+> $ hadrian/build.sh --flavour=quickest -j "stage1.ghc-bin.ghc.link.opts += -v3"
+
+or in a file at <build root>/hadrian.settings, where <build root>
+is the build root to be used for the build, which is _build by default.
+For example, you could create a file at _build/hadrian.settings with the
+following contents:
+
+> stage1.ghc-bin.ghc.link.opts += -v3
+> stage1.base.ghc.hs.opts += -ddump-timings
+
+and issue:
+
+> $ hadrian/build.sh
+
+Hadrian would pick up the settings given in _build/hadrian.settings (as well as
+any settings that you may additionally be passing on the command line) and
+update the relevant flavour accordingly, to issue the additional arguments
+specified by the user.
+
+The supported settings are described by 'builderSetting' below, using
+operations from Applicative + two new primitives, 'matchString' and
+'matchOneOf', that come as members of the 'Match' class. This gives us
+a simple but powerful vocabulary to describe settings and parse them
+into values that we can use to compute interesting things, like a 'Predicate'
+that we can use to emit additional arguments, or a list of possible completions.
+
+> fmap, (<$>) :: Functor f => (a -> b) -> f a -> f b
+> pure :: Applicative f => a -> f a
+> (<*>) :: Applicative f => f (a -> b) -> f a -> f b
+> (*>) :: Applicative f => f a -> f b -> f b
+> (<*) :: Applicative f => f a -> f b -> f a
+> (<$) :: Functor f => a -> f b -> f a
+>
+> str :: Match f => String -> f ()
+> val :: Match f => String -> a -> f a
+> oneOf :: Match f => [f a] -> f a
+> choose :: Match f => [(String, a)] -> f a
+> wild :: Match f => [(String, a)] -> f (Wildcard a)
+
+For instance, to describe possible settings:
+ foo.bar.{x, y}
+ foo.baz.{a, b}.c
+
+we could write:
+
+> str "foo" *> oneOf [ str "bar" *> choose [ ("x", "x"), ("y", "y") ]
+> , str "baz" *> choose [ ("a", "ac"), ("b", "bc") <* str "c" ]
+> ]
+
+'builderSetting' uses these combinators to describe the setting keys that
+Hadrian supports. A user-oriented description of this mechanism is available
+in hadrian/doc/user-settings.md.
+
+-}
+
+-- | Try to interpret all the 'KeyVal' as flavour updates, keeping
+-- a list of errors for the ones which don't match known
+-- settings.
+applySettings :: [KeyVal] -> ([SettingError], Flavour -> Flavour)
+applySettings kvs = case partitionEithers (map applySetting kvs) of
+ (errs, fs) -> (errs, foldr (flip (.)) id fs)
+ -- we need to compose the reverse way to have the following settings
+ -- x = -b
+ -- x += -c
+ -- produce the final x = "-b -c" value. With just (.) we would apply
+ -- the x = -b assignment last, which would silently drop the -c adddition.
+ --
+ -- foldr (.) id [f, g, h] = f . g . h
+ -- -- first function (f) is applied last, we're applying them in
+ -- -- the wrong order!
+ --
+ -- foldr (flip (.)) id [f, g, h] = h . g . f
+ -- -- last function (f) is applied last, as desired
+
+
+-- | Try to interpret the given 'KeyVal' as a flavour update
+-- function, returning an error if it doesn't match a known
+-- setting.
+applySetting :: KeyVal -> Either SettingError (Flavour -> Flavour)
+applySetting (KeyVal ks op v) = case runSettingsM ks builderPredicate of
+ Left err -> throwError $
+ "error while setting " ++ show ks ++ ": " ++ err
+ Right pred -> Right $ \flav -> flav
+ { args = update (args flav) pred }
+
+ where override arguments predicate = do
+ holds <- predicate
+ if holds then pure (words v) else arguments
+
+ augment arguments predicate =
+ mconcat [arguments, predicate ? pure (words v)]
+
+ update
+ | op == Equal = override
+ | otherwise = augment
+
+-- | Try to auto-complete the given @Key@ using
+-- all known settings, as described by 'builderSetting'.
+--
+-- > completeSetting ["stage1","base", "ghc"]
+-- > -- returns [ ["stage1","base","ghc","c","opts"]
+-- > -- , ["stage1","base","ghc","hs","opts"]
+-- > -- , ["stage1","base","ghc","link","opts"]
+-- > -- , ["stage1","base","ghc","deps","opts"]
+-- > -- , ["stage1","base","ghc","toolargs","opts"]
+-- > -- ]
+completeSetting :: Key -> [Key]
+completeSetting ks = map snd (complete ks builderSetting)
+
+-- | Interpret a 'builderSetting' as a 'Predicate' that
+-- potentially constrains on the stage, package or
+-- (ghc or cc) builder mode.
+--
+-- For example, @stage1.base.ghc.link.opts@ gets mapped to
+-- a predicate that applies @'stage' 'Stage1'@,
+-- @'package' 'base'@ and @'builder' ('Ghc' 'LinkHs')@.
+builderPredicate :: SettingsM Predicate
+builderPredicate = builderSetting <&> (\(wstg, wpkg, builderMode) ->
+ wildcard (pure True) stage wstg <&&>
+ wildcard (pure True) package wpkg <&&>
+ (case builderMode of
+ Left ghcMode -> wildcard (builder Ghc) (builder . Ghc) ghcMode
+ Right ccMode -> wildcard (builder Cc) (builder . Cc) ccMode))
+
+ where (<&&>) = liftA2 (&&)
+
+-- | Interpretation-agnostic description of the builder settings
+-- supported by Hadrian.
+--
+-- Supported settings (to be kept in sync with the code):
+--
+-- > (<stage> or *).(<package name> or *).ghc.(<ghc mode> or *).opts
+-- > (<stage> or *).(<package name> or *).cc.(<cc mode> or *).opts
+--
+-- where:
+-- - @<stage>@ is one of @stage0@, @stage1@, @stage2@ or @stage3@;
+-- - @<package name>@ is the (Cabal) name of a package (@base@,
+-- @template-haskell@, ...);
+-- - @<ghc mode>@ is one of @c@ (building C files), @hs@ (building Haskell
+-- modules), @link@ (linking object files), @deps@ (finding Haskell
+-- dependencies with @ghc -M@) or @toolargs@ (getting necessary flags to
+-- make hadrian/ghci.sh work;
+-- - @<cc mode>@ is one of @c@ (building C files) or @deps@ (finding C
+-- dependencies);
+-- - locations that support a wildcard (@*@) entry are here to avoid
+-- repetition, a wildcard entry being equivalent to writing all the
+-- settings that the wildcard matches over; in our case, we can
+-- apply GHC or C compiler options uniformly over all stages, packages
+-- and compiler modes, if we so desire, by using a wildcard in the
+-- appropriate spot.
+builderSetting :: Match f => f (Wildcard Stage, Wildcard Package, Either (Wildcard GhcMode) (Wildcard CcMode))
+builderSetting = (,,)
+ <$> wild stages
+ <*> wild pkgs
+ <*> matchOneOf
+ [ str "ghc" *> fmap Left (wild ghcBuilder) <* str "opts"
+ , str "cc" *> fmap Right (wild ccBuilder) <* str "opts"
+ ]
+
+ where ghcBuilder =
+ [ ("c", CompileCWithGhc)
+ , ("deps", FindHsDependencies)
+ , ("hs", CompileHs)
+ , ("link", LinkHs)
+ , ("toolargs", ToolArgs)
+ ]
+
+ ccBuilder =
+ [ ("c", CompileC)
+ , ("deps", FindCDependencies)
+ ]
+
+ stages = map (\stg -> (stageString stg, stg)) [minBound..maxBound]
+
+ pkgs = map (\pkg -> (pkgName pkg, pkg)) knownPackages
diff --git a/hadrian/src/Settings/Parser.hs b/hadrian/src/Settings/Parser.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d93f71ae06e3abfe5cfa0d4438147430ef1194cd
--- /dev/null
+++ b/hadrian/src/Settings/Parser.hs
@@ -0,0 +1,276 @@
+{-# LANGUAGE FlexibleContexts #-}
+-- | Utilities for implementing key-value settings, as described in Note [Hadrian settings]
+module Settings.Parser where
+
+import Control.Applicative
+import Control.Monad.Except
+import Control.Monad.State as State
+import Data.Either
+import Data.List
+
+import qualified Text.Parsec as Parsec
+
+-- * Raw parsing of @key = value@ or @key += value@ expressions
+
+-- | A 'Key' is parsed from a dot-separated list of words.
+type Key = [String]
+
+-- | A 'Val'ue is any 'String'.
+type Val = String
+
+-- | 'Equal' when overriding the entire computation of a setting with some
+-- fresh values, 'PlusEqual' when extending it.
+data Op = Equal | PlusEqual
+ deriving (Eq, Ord, Show)
+
+-- | A 'KeyVal' represents an expression @foo.bar.baz [+]= v@.
+data KeyVal = KeyVal Key Op Val
+ deriving (Eq, Ord, Show)
+
+-- | Pretty-print 'KeyVal's.
+ppKeyVals :: [KeyVal] -> String
+ppKeyVals = unlines . map ppKeyVal
+
+-- | Pretty-print a 'KeyVal'.
+ppKeyVal :: KeyVal -> String
+ppKeyVal (KeyVal k op v) =
+ intercalate "." k ++ " " ++ opstr ++ " " ++ v
+
+ where opstr = case op of
+ Equal -> "="
+ PlusEqual -> "+="
+
+-- | Remove any string that can be parsed as a 'KeyVal' from the
+-- given list.
+removeKVs :: [String] -> [String]
+removeKVs xs = fst (partitionKVs xs)
+
+-- | Try to parse all strings of the given list as 'KeyVal's and keep
+-- only the successful parses.
+parseJustKVs :: [String] -> [KeyVal]
+parseJustKVs xs = snd (partitionKVs xs)
+
+-- | Try to parse all strings from the given list as 'KeyVal's and return
+-- the ones for which parsing fails in the first component of the pair,
+-- and the successful parses in the second component of the pair.
+partitionKVs :: [String] -> ([String], [KeyVal])
+partitionKVs xs = partitionEithers $
+ map (\x -> either (const $ Left x) Right $ parseKV x) xs
+
+-- | Try to parse all strings from the input list as 'KeyVal's.
+parseKVs :: [String] -> [Either Parsec.ParseError KeyVal]
+parseKVs = map parseKV
+
+-- | Try to parse the given string as a 'KeyVal'.
+parseKV :: String -> Either Parsec.ParseError KeyVal
+parseKV = Parsec.parse parseKeyVal "<string list>"
+
+-- | This implements a parser that supports @key = val@, @key = "val"@,
+-- @key += val@, @key += "val"@ style syntax, where there can be 0 or more
+-- spaces between the key and the operator, and the operator and the value.
+parseKeyVal :: Parsec.Parsec String () KeyVal
+parseKeyVal = do
+ k <- parseKey
+ skipSpaces
+ op <- parseOp
+ skipSpaces
+ v <- parseValue
+ return (KeyVal k op v)
+
+ where skipSpaces = Parsec.optional (Parsec.many1 (Parsec.oneOf " \t"))
+
+-- | Parse a dot-separated list of alpha-numerical words that can contain
+-- dashes, just not at the beginning.
+parseKey :: Parsec.Parsec String () Key
+parseKey =
+ Parsec.sepBy1 (starOr $ liftA2 (:) Parsec.alphaNum $
+ Parsec.many (Parsec.alphaNum <|> Parsec.char '-')
+ )
+ (Parsec.char '.')
+
+ where starOr :: Parsec.Parsec String () String -> Parsec.Parsec String () String
+ starOr p = ((\x -> [x]) <$> Parsec.char '*') <|> p
+
+-- | Parse @=@ or @+=@.
+parseOp :: Parsec.Parsec String () Op
+parseOp = Parsec.choice
+ [ Parsec.char '=' *> pure Equal
+ , Parsec.string "+=" *> pure PlusEqual
+ ]
+
+-- | Parse @some string@ or @\"some string\"@.
+parseValue :: Parsec.Parsec String () Val
+parseValue = Parsec.optional (Parsec.char '\"') >> Parsec.manyTill Parsec.anyChar ((Parsec.char '\"' >> pure ()) <|> Parsec.eof)
+
+-- * Expressing settings
+
+-- | The current key component must match the given string.
+str :: Match f => String -> f ()
+str = matchString
+
+-- | Like 'str', but returns the second argument insead of @()@.
+--
+-- > val s a = str s *> pure a
+val :: Match f => String -> a -> f a
+val s a = str s *> pure a
+
+-- | Try and match one of the given "matchers".
+--
+-- > oneOf [str "hello", str "hi"] -- matches "hello" or "hi"
+oneOf :: Match f => [f a] -> f a
+oneOf = matchOneOf
+
+-- | Try and match one of the given strings, returning the corresponding
+-- value (the @a@) when the input matches.
+choose :: Match f => [(String, a)] -> f a
+choose xs = oneOf $ map (uncurry val) xs
+
+-- | Try and match one of the given strings, or @*@, and return
+-- the corresponding value (@One someValue@ or @Wildcard@ respectively).
+wild :: Match f => [(String, a)] -> f (Wildcard a)
+wild xs = choose $ ("*", Wildcard) : map (fmap One) xs
+
+-- * Wildcards (@*@) in settings
+
+-- | A @'Wildcard' a@ is either 'Wildcard' or @One x@ where @x :: a@.
+data Wildcard a = Wildcard | One a
+ deriving (Eq, Ord, Show)
+
+-- | Elimination rule for 'Wildcard'. The first argument is returned
+-- when the input is 'Wildcard', and when it's not the second argument
+-- is applied to the value wrapped behind 'One'.
+wildcard :: b -> (a -> b) -> Wildcard a -> b
+wildcard z f x = case x of
+ Wildcard -> z
+ One a -> f a
+
+-- * 'Match' class, to interpret settings in various ways
+
+-- 'matchOneOf' is similar in spirit to Alternative's '<|>',
+-- but we don't really have an identity ('empty').
+--
+-- 'matchString' on the other hand is just a handy primitive.
+--
+-- Selective functors may be relevant here...?
+
+-- | Equip the 'Applicative' class with a primitive to match a known string,
+-- and another to try and match a bunch of "alternatives", returning
+-- the first one that succeeds.
+class Applicative f => Match f where
+ matchString :: String -> f ()
+ matchOneOf :: [f a] -> f a
+
+-- * 'SettingsM' interpretation
+
+type SettingError = String
+
+type SettingsM = StateT Key (Either SettingError)
+
+-- | Runs the 'SettingsM' computation, returning the value at the leaf
+-- when the given 'Key' matches exactly at least one setting, erroring
+-- out when it is too long or just doesn't match.
+runSettingsM :: Key -> SettingsM a -> Either SettingError a
+runSettingsM k m = case runStateT m k of
+ Left err -> Left err
+ Right (a, []) -> return a
+ Right (_, xs) -> throwError $ "suffix " ++ show xs ++ " not found in settings"
+
+-- | Stateful manipulation of the remaining key components,
+-- with errors when strings don't match.
+instance Match SettingsM where
+ matchString = matchStringSettingsM
+ matchOneOf = matchOneOfSettingsM
+
+matchStringSettingsM :: String -> SettingsM ()
+matchStringSettingsM s = do
+ ks <- State.get
+ if null ks
+ then throwError $ "expected " ++ show s ++ ", got nothing"
+ else go (head ks)
+
+ where go k
+ | k == s = State.modify tail
+ | otherwise = throwError $
+ "expected " ++ show s ++ ", got " ++ show k
+
+matchOneOfSettingsM :: [SettingsM a] -> SettingsM a
+matchOneOfSettingsM acts = StateT $ \k -> do
+ firstMatch $ map (($ k) . State.runStateT) acts
+
+ where firstMatch
+ :: [Either SettingError (a, Key)]
+ -> Either SettingError (a, Key)
+ firstMatch [] = throwError "matchOneOf: no match"
+ firstMatch (Left _ : xs) = firstMatch xs
+ firstMatch (Right res : _) = return res
+
+-- * Completion interpretation
+
+-- | A tree with values at the leaves ('Pure'), but where we can
+-- have "linear links" with strings attached.
+--
+-- - @'Known' s t@ nodes are used to represent matching against
+-- known strings;
+-- - @'Branch' ts@ nodes are used to represent matching against a list
+-- of "matchers";
+-- - @'Pure' a@ nodes are used to attach values at the leaves, and help
+-- provide an 'Applicative' interface.
+data CompletionTree a
+ = Known String (CompletionTree a)
+ | Branch [CompletionTree a]
+ | Pure a
+ deriving (Eq, Show)
+
+-- | Traverses 'Known' and 'Branch' nodes, only applying the
+-- function to values at the leaves, wrapped with 'Pure'.
+instance Functor CompletionTree where
+ fmap f (Known s t) = Known s (fmap f t)
+ fmap f (Branch ts) = Branch (map (fmap f) ts)
+ fmap f (Pure a) = Pure (f a)
+
+-- | 'pure' is 'Pure', '<*>' distributes the choices.
+instance Applicative CompletionTree where
+ pure = Pure
+
+ Pure f <*> Pure x = Pure (f x)
+ Pure f <*> Known s t = Known s (fmap f t)
+ Pure f <*> Branch xs = Branch (map (fmap f) xs)
+ Known s t <*> t' = Known s (t <*> t')
+ Branch ts <*> t' = Branch (map (<*> t') ts)
+
+-- | 'matchString' gets mapped to 'Known', 'matchOneOf' to 'Branch'.
+instance Match CompletionTree where
+ matchString s = Known s (Pure ())
+ matchOneOf xs = Branch xs
+
+-- | Enumerate all the keys a completion tree represents, with the corresponding
+-- leave values.
+--
+-- > enumerate (val "hello" 1)) -- [(1, ["hello"])]
+enumerate :: CompletionTree a -> [(a, Key)]
+enumerate = go []
+
+ where go ks (Known s t) = go (s:ks) t
+ go ks (Branch xs) = concatMap (go ks) xs
+ go ks (Pure a) = [(a, reverse ks)]
+
+-- | Enumerate all the valid completions for the given input (a partially-written
+-- setting key).
+--
+-- > complete ["hel"] (val 1 "hello")
+-- > -- returns [(1, ["hello"])]
+-- > complete ["foo"] (str "foo" *> oneOf [val "hello" 1, val "world" 2])
+-- > -- returns [(1, ["foo", "hello"]), (2, ["foo", "world"])]
+complete :: [String] -> CompletionTree a -> [(a, Key)]
+complete [] t = enumerate t
+complete (k:ks) t = case t of
+ Known s t'
+ | k == s -> map (fmap (s:)) (complete ks t')
+ | (k `isPrefixOf` s) && null ks -> map (fmap (s:)) (enumerate t')
+ -- TODO: use an Either to indicate suggestions about
+ -- typos somewhere in the middle (not for the final component)
+ -- (e.g "You wrote stage1.ghc-bi.ghc.hs.opts but probably
+ -- meant stage1.ghc-bin.ghc.hs.opts") ?
+ | otherwise -> []
+ Branch ts -> concatMap (complete (k:ks)) ts
+ Pure a -> return (a, [])