diff options
author | Alp Mestanogullari <alpmestan@gmail.com> | 2019-06-24 20:43:49 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-07-09 22:57:31 -0400 |
commit | 18ac9ad404f490bd7ea0639a1b85a88ed4502613 (patch) | |
tree | b623b43f77709e148a83cef6f5b3be192ce15640 /hadrian | |
parent | 42ff8653bd5ce7f00af5783f2973393ebfcd7cc7 (diff) | |
download | haskell-18ac9ad404f490bd7ea0639a1b85a88ed4502613.tar.gz |
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
Diffstat (limited to 'hadrian')
-rwxr-xr-x | hadrian/completion.sh | 7 | ||||
-rw-r--r-- | hadrian/doc/user-settings.md | 126 | ||||
-rw-r--r-- | hadrian/hadrian.cabal | 1 | ||||
-rw-r--r-- | hadrian/src/CommandLine.hs | 52 | ||||
-rw-r--r-- | hadrian/src/Hadrian/BuildPath.hs | 24 | ||||
-rw-r--r-- | hadrian/src/Main.hs | 6 | ||||
-rw-r--r-- | hadrian/src/Rules.hs | 1 | ||||
-rw-r--r-- | hadrian/src/Rules/Register.hs | 2 | ||||
-rw-r--r-- | hadrian/src/Rules/SimpleTargets.hs | 21 | ||||
-rwxr-xr-x | hadrian/src/Settings.hs | 212 | ||||
-rw-r--r-- | hadrian/src/Settings/Parser.hs | 276 |
11 files changed, 688 insertions, 40 deletions
diff --git a/hadrian/completion.sh b/hadrian/completion.sh new file mode 100755 index 0000000000..589fdf5795 --- /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 84298684c4..6a1d5be847 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 1e7287cb92..2c5781f196 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 461898cdfd..aad616f40a 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 6fa4b7f383..499897d177 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 63001fe53b..804144aeb1 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 240e08dcdc..851ccc05c7 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 b6acf566f7..4275ab1fa2 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 d005043164..1ce3418665 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 d3096e7987..0548bccfae 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 0000000000..d93f71ae06 --- /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, []) |