hadrian: Introduce notion of flavour transformers

This extends Hadrian's notion of "flavour", as described in #18942.

2 files changed, 60 insertions, 5 deletions

diff --git a/hadrian/src/Flavour.hs b/hadrian/src/Flavour.hs
index 364261259f..06f72a06eb 100644
--- a/hadrian/src/Flavour.hs
+++ b/hadrian/src/Flavour.hs
@@ -1,7 +1,9 @@
 module Flavour
   ( Flavour (..), werror
   , DocTargets, DocTarget(..)
+  , parseFlavour
     -- * Flavour transformers
+  , flavourTransformers
   , addArgs
   , splitSections, splitSectionsIf
   , enableThreadSanitizer
@@ -10,8 +12,14 @@ module Flavour
 
 import Expression
 import Data.Set (Set)
+import Data.Map (Map)
+import qualified Data.Map as M
 import Packages
 
+import Text.Parsec.Prim as P
+import Text.Parsec.Combinator as P
+import Text.Parsec.Char as P
+
 -- 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:
@@ -69,6 +77,55 @@ type DocTargets = Set DocTarget
 data DocTarget = Haddocks | SphinxHTML | SphinxPDFs | SphinxMan | SphinxInfo
   deriving (Eq, Ord, Show, Bounded, Enum)
 
+flavourTransformers :: Map String (Flavour -> Flavour)
+flavourTransformers = M.fromList
+    [ "werror" =: werror
+    , "debug_info" =: enableDebugInfo
+    , "ticky_ghc" =: enableTickyGhc
+    , "split_sections" =: splitSections
+    , "thread_sanitizer" =: enableThreadSanitizer
+    ]
+  where (=:) = (,)
+
+type Parser = Parsec String ()
+
+parseFlavour :: [Flavour]  -- ^ base flavours
+             -> Map String (Flavour -> Flavour) -- ^ modifiers
+             -> String
+             -> Either String Flavour
+parseFlavour baseFlavours transformers str =
+    case P.runParser parser () "" str of
+      Left perr -> Left $ unlines $
+                    [ "error parsing flavour specifier: " ++ show perr
+                    , ""
+                    , "known flavours:"
+                    ] ++
+                    [ "  " ++ name f | f <- baseFlavours ] ++
+                    [ ""
+                    , "known flavour transformers:"
+                    ] ++
+                    [ "  " ++ nm | nm <- M.keys transformers ]
+      Right f -> Right f
+  where
+    parser :: Parser Flavour
+    parser = do
+      base <- baseFlavour
+      transs <- P.many flavourTrans
+      return $ foldr ($) base transs
+
+    baseFlavour :: Parser Flavour
+    baseFlavour =
+        P.choice [ f <$ P.try (P.string (name f))
+                 | f <- baseFlavours
+                 ]
+
+    flavourTrans :: Parser (Flavour -> Flavour)
+    flavourTrans = do
+        void $ P.char '+'
+        P.choice [ trans <$ P.try (P.string nm)
+                 | (nm, trans) <- M.toList transformers
+                 ]
+
 -- | Add arguments to the 'args' of a 'Flavour'.
 addArgs :: Args -> Flavour -> Flavour
 addArgs args' fl = fl { args = args fl <> args' }
diff --git a/hadrian/src/Settings.hs b/hadrian/src/Settings.hs
index ff51c01acb..43af1330ca 100755
--- a/hadrian/src/Settings.hs
+++ b/hadrian/src/Settings.hs
@@ -75,11 +75,9 @@ flavour = do
     let flavours = hadrianFlavours ++ userFlavours
         (_settingErrs, tweak) = applySettings kvs
 
-    return $
-      case filter (\fl -> name fl == flavourName) flavours of
-        []  -> error $ "Unknown build flavour: " ++ flavourName
-        [f] -> tweak f
-        _   -> error $ "Multiple build flavours named " ++ flavourName
+    case parseFlavour flavours flavourTransformers flavourName of
+      Left err -> fail err
+      Right f -> return $ tweak f
 
 -- TODO: switch to Set Package as the order of packages should not matter?
 -- Otherwise we have to keep remembering to sort packages from time to time.