1 files changed, 57 insertions, 0 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' }