Hadrian: implement key-value settings for builder options

They take the general form `foo.bar.baz [+]= some values`, where
`=` completely overrides the arguments for a builder and `+=` extends
them. We currenly only support settings for updating the GHC and C
compiler options, of the form:

```
  {stage0, ..., stage3 or *}.{package name or *}
                            .ghc.{c, hs, link, deps, toolargs or *}.opts

  {stage0, ..., stage3 or *}.{package name or *}
                            .cc.{c, deps or *}.opts
```

The supported settings and their use is covered in the new section
of `hadrian/doc/user-settings.md`, while the implementation is explained
in a new Note [Hadrian settings].

Most of the logic is implemented in a new module, `Settings.Parser`, which
contains key-value assignment/extension parsers as well as utilities for
specifying allowed settings at a high-level, generating a `Predicate` from
such a description or generating the list of possible completions for a given
string.

The additions to the `Settings` module make use of this to describe the
settings that Hadrian currently supports, and apply all such
key-value settings (from the command line and `<root>/hadrian.settings`)
to the flavour that Hadrian is going to proceed with.

This new setting system comes with support for generating Bash completions,
implemented in `hadrian/completion.sh` and Hadrian's `autocomplete` target:

> source hadrian/completion.sh
> hadrian/build.sh stage1.base.ghc.<TAB>
stage1.base.ghc.c.opts     stage1.base.ghc.hs.opts
stage1.base.ghc.*.opts     stage1.base.ghc.deps.opts
stage1.base.ghc.link.opts  stage1.base.ghc.toolargs.opts

hadrian/completion.sh

+#!/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

hadrian/doc/user-settings.md

-# 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

hadrian/hadrian.cabal

@@ -101,6 +101,7 @@ executable hadrian
                        , Settings.Flavours.Quickest
                        , Settings.Flavours.GhcInGhci
                        , Settings.Packages
+                       , Settings.Parser
                        , Settings.Warnings
                        , Stage
                        , Target

hadrian/src/CommandLine.hs

 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
 

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

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

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

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

hadrian/src/Rules/SimpleTargets.hs

-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

hadrian/src/Settings.hs

 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

hadrian/src/Settings/Parser.hs

+{-# 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, [])