hadrian: Reorganise modules so KV parser can be used to define transformers

1 files changed, 220 insertions, 57 deletions

diff --git a/hadrian/src/Flavour.hs b/hadrian/src/Flavour.hs
index df918b5a8f..61bca98053 100644
--- a/hadrian/src/Flavour.hs
+++ b/hadrian/src/Flavour.hs
@@ -12,74 +12,25 @@ module Flavour
   , enableProfiledGhc
   , disableDynamicGhcPrograms
   , disableProfiledLibs
+
+  , completeSetting
+  , applySettings
   ) where
 
 import Expression
-import Data.Set (Set)
+import Data.Either
 import Data.Map (Map)
 import qualified Data.Map as M
 import Packages
+import Flavour.Type
+import Settings.Parser
 
 import Text.Parsec.Prim as P
 import Text.Parsec.Combinator as P
 import Text.Parsec.Char as P
+import Control.Monad.Except
+import UserSettings
 
--- Please update doc/{flavours.md, user-settings.md} when changing this file.
--- | 'Flavour' is a collection of build settings that fully define a GHC build.
--- Note the following type semantics:
--- * @Bool@: a plain Boolean flag whose value is known at compile time.
--- * @Action Bool@: a flag whose value can depend on the build environment.
--- * @Predicate@: a flag whose value can depend on the build environment and
--- on the current build target.
-data Flavour = Flavour {
-    -- | Flavour name, to select this flavour from command line.
-    name :: String,
-    -- | Use these command line arguments.
-    args :: Args,
-    -- | Build these packages.
-    packages :: Stage -> Action [Package],
-    -- | 'native', 'gmp', 'ffi'.
-    bignumBackend :: String,
-    -- | Check selected backend against native backend
-    bignumCheck :: Bool,
-    -- | Build libraries these ways.
-    libraryWays :: Ways,
-    -- | Build RTS these ways.
-    rtsWays :: Ways,
-    -- | Build dynamic GHC programs.
-    dynamicGhcPrograms :: Action Bool,
-    -- | Enable GHCi debugger.
-    ghciWithDebugger :: Bool,
-    -- | Build profiled GHC.
-    ghcProfiled :: Bool,
-    -- | Build GHC with debugging assertions.
-    ghcDebugged :: Bool,
-    -- | Build the GHC executable against the threaded runtime system.
-    ghcThreaded :: Bool,
-    -- | Whether to build docs and which ones
-    --   (haddocks, user manual, haddock manual)
-    ghcDocs :: Action DocTargets }
-
--- | A set of documentation targets
-type DocTargets = Set DocTarget
-
--- | Documentation targets
---
---   While we can't reasonably expose settings or CLI options
---   to selectively disable, say, base's haddocks, we can offer
---   a less fine-grained choice:
---
---   - haddocks for libraries
---   - non-haddock html pages (e.g GHC's user manual)
---   - PDF documents (e.g haddock's manual)
---   - man pages (GHC's)
---
---   The main goal being to have easy ways to do away with the need
---   for e.g @sphinx-build@ or @xelatex@ and associated packages
---   while still being able to build a(n almost) complete binary
---   distribution.
-data DocTarget = Haddocks | SphinxHTML | SphinxPDFs | SphinxMan | SphinxInfo
-  deriving (Eq, Ord, Show, Bounded, Enum)
 
 flavourTransformers :: Map String (Flavour -> Flavour)
 flavourTransformers = M.fromList
@@ -227,3 +178,215 @@ disableDynamicGhcPrograms flavour = flavour { dynamicGhcPrograms = pure False }
 disableProfiledLibs :: Flavour -> Flavour
 disableProfiledLibs flavour =
     flavour { libraryWays = filter (not . wayUnit Profiling) <$> libraryWays flavour }
+
+
+-- * 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 --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
+
+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 `" ++ intercalate "`." 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
+       BM_Ghc ghcMode -> wildcard (builder Ghc) (builder . Ghc) ghcMode
+       BM_Cc  ccMode  -> wildcard (builder Cc) (builder . Cc) ccMode
+       BM_CabalConfigure -> builder (Cabal Setup)
+       BM_RunTest     -> builder RunTest
+    )
+  )
+
+  where (<&&>) = liftA2 (&&)
+
+-- | Which builder a setting should apply to
+data BuilderMode = BM_Ghc (Wildcard GhcMode)
+                 | BM_Cc  (Wildcard CcMode)
+                 | BM_CabalConfigure
+                 | BM_RunTest
+
+-- | 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
+--   > (<stage> or *).(<package name> or *).cabal.configure.opts
+--   > runtest.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 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, BuilderMode)
+builderSetting =
+    matchOneOf
+    [ (,,)
+       <$> wild stages
+       <*> wild pkgs
+       <*> matchOneOf
+             [ str "ghc" *> fmap BM_Ghc (wild ghcBuilder) <* str "opts"
+             , str "cc" *> fmap BM_Cc (wild ccBuilder) <* str "opts"
+             , BM_CabalConfigure <$ str "cabal" <* str "configure" <* str "opts"
+             ]
+    , (Wildcard, Wildcard, BM_RunTest)
+      <$ str "runtest" <* str "opts"
+    ]
+  where ghcBuilder =
+          [ ("c", CompileCWithGhc)
+          , ("cpp", CompileCppWithGhc)
+          , ("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)) (ghcPackages ++ userPackages)
+