Refactor build flavours

See #268.

hadrian.cabal

@@ -24,6 +24,7 @@ executable hadrian
                        , Context
                        , Environment
                        , Expression
+                       , Flavour
                        , GHC
                        , Oracles.ArgsHash
                        , Oracles.Config
@@ -68,7 +69,6 @@ executable hadrian
                        , Rules.Wrappers.Ghc
                        , Rules.Wrappers.GhcPkg
                        , Settings
-                       , Settings.Args
                        , Settings.Builders.Alex
                        , Settings.Builders.Ar
                        , Settings.Builders.Common
@@ -90,7 +90,6 @@ executable hadrian
                        , Settings.Default
                        , Settings.Flavours.Quick
                        , Settings.Flavours.Quickest
-                       , Settings.Packages
                        , Settings.Packages.Base
                        , Settings.Packages.Compiler
                        , Settings.Packages.Directory
@@ -106,7 +105,6 @@ executable hadrian
                        , Settings.Packages.Touchy
                        , Settings.Packages.Unlit
                        , Settings.Paths
-                       , Settings.Ways
                        , Stage
                        , Target
                        , UserSettings

src/CmdLineFlag.hs

 module CmdLineFlag (
-    putCmdLineFlags, cmdFlags, cmdBuildHaddock, cmdFlavour, Flavour (..),
-    cmdProgressColour, ProgressColour (..), cmdProgressInfo, ProgressInfo (..),
-    cmdSkipConfigure, cmdSplitObjects
+    putCmdLineFlags, cmdFlags, cmdBuildHaddock, cmdFlavour, cmdProgressColour,
+    ProgressColour (..), cmdProgressInfo, ProgressInfo (..), cmdSkipConfigure,
+    cmdSplitObjects
     ) where
 
 import Data.IORef
@@ -14,14 +14,13 @@ import System.IO.Unsafe
 -- build rules to be rurun.
 data Untracked = Untracked
     { buildHaddock   :: Bool
-    , flavour        :: Flavour
+    , flavour        :: Maybe String
     , progressColour :: ProgressColour
     , progressInfo   :: ProgressInfo
     , skipConfigure  :: Bool
     , splitObjects   :: Bool }
     deriving (Eq, Show)
 
-data Flavour        = Default | Quick | Quickest deriving (Eq, Show)
 data ProgressColour = Never | Auto | Always deriving (Eq, Show)
 data ProgressInfo   = None | Brief | Normal | Unicorn deriving (Eq, Show)
 
@@ -29,7 +28,7 @@ data ProgressInfo   = None | Brief | Normal | Unicorn deriving (Eq, Show)
 defaultUntracked :: Untracked
 defaultUntracked = Untracked
     { buildHaddock   = False
-    , flavour        = Default
+    , flavour        = Nothing
     , progressColour = Auto
     , progressInfo   = Normal
     , skipConfigure  = False
@@ -39,16 +38,7 @@ readBuildHaddock :: Either String (Untracked -> Untracked)
 readBuildHaddock = Right $ \flags -> flags { buildHaddock = True }
 
 readFlavour :: Maybe String -> Either String (Untracked -> Untracked)
-readFlavour ms =
-    maybe (Left "Cannot parse flavour") (Right . set) (go =<< lower <$> ms)
-  where
-    go :: String -> Maybe Flavour
-    go "default"  = Just Default
-    go "quick"    = Just Quick
-    go "quickest" = Just Quickest
-    go _          = Nothing
-    set :: Flavour -> Untracked -> Untracked
-    set flag flags = flags { flavour = flag }
+readFlavour ms = Right $ \flags -> flags { flavour = ms }
 
 readProgressColour :: Maybe String -> Either String (Untracked -> Untracked)
 readProgressColour ms =
@@ -112,7 +102,7 @@ getCmdLineFlags = unsafePerformIO $ readIORef cmdLineFlags
 cmdBuildHaddock :: Bool
 cmdBuildHaddock = buildHaddock getCmdLineFlags
 
-cmdFlavour :: Flavour
+cmdFlavour :: Maybe String
 cmdFlavour = flavour getCmdLineFlags
 
 cmdProgressColour :: ProgressColour

src/Flavour.hs

+module Flavour (Flavour (..)) where
+
+import Expression
+
+-- TODO: Merge {libraryWays, rtsWays}, and {dynamicGhcPrograms, ghcProfiled...}.
+-- | 'Flavour' is a collection of build settings that fully define a GHC build.
+data Flavour = Flavour
+    { name               :: String    -- ^ Flavour name, to set from command line.
+    , args               :: Args      -- ^ Use these command line arguments.
+    , packages           :: Packages  -- ^ Build these packages.
+    , libraryWays        :: Ways      -- ^ Build libraries these ways.
+    , rtsWays            :: Ways      -- ^ Build RTS these ways.
+    , splitObjects       :: Predicate -- ^ Build split objects.
+    , buildHaddock       :: Predicate -- ^ Build Haddock and documentation.
+    , dynamicGhcPrograms :: Bool      -- ^ Build dynamic GHC programs.
+    , ghciWithDebugger   :: Bool      -- ^ Enable GHCi debugger.
+    , ghcProfiled        :: Bool      -- ^ Build profiled GHC.
+    , ghcDebugged        :: Bool }    -- ^ Build GHC with debug information.

src/Oracles/ArgsHash.hs

@@ -4,8 +4,8 @@ module Oracles.ArgsHash (checkArgsHash, argsHashOracle) where
 import Base
 import Expression
 import Settings
-import Settings.Args
 import Target
+import UserSettings
 
 newtype ArgsHashKey = ArgsHashKey Target
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)

src/Oracles/Dependencies.hs

@@ -11,6 +11,7 @@ import Expression
 import Oracles.PackageData
 import Settings
 import Settings.Builders.GhcCabal
+import Settings.Paths
 
 newtype ObjDepsKey = ObjDepsKey (FilePath, FilePath)
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)

src/Oracles/WindowsPath.hs

 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Oracles.WindowsPath (
-    fixAbsolutePathOnWindows, topDirectory, windowsPathOracle
+    fixAbsolutePathOnWindows, topDirectory, getTopDirectory, windowsPathOracle
     ) where
 
+-- TODO: Rename to Oracles.Path.
+
+import Control.Monad.Trans.Reader
 import Data.Char
 
 import Base
@@ -15,6 +18,9 @@ newtype WindowsPath = WindowsPath FilePath
 topDirectory :: Action FilePath
 topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
 
+getTopDirectory :: ReaderT a Action FilePath
+getTopDirectory = lift topDirectory
+
 -- | Fix an absolute path on Windows:
 -- * "/c/" => "C:/"
 -- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"

src/Rules.hs

 module Rules (topLevelTargets, buildRules) where
 
-import Data.Foldable
-
 import Base
 import Context
 import Expression
+import Flavour
 import GHC
 import qualified Rules.Compile
 import qualified Rules.Data
@@ -20,25 +19,26 @@ import qualified Rules.Perl
 import qualified Rules.Program
 import qualified Rules.Register
 import Settings
+import Settings.Paths
 
 allStages :: [Stage]
 allStages = [minBound ..]
 
--- | 'need' all top-level build targets
+-- | This rule 'need' all top-level build targets.
 topLevelTargets :: Rules ()
 topLevelTargets = do
 
     want $ Rules.Generate.installTargets
 
-    -- TODO: do we want libffiLibrary to be a top-level target?
+    -- TODO: Do we want libffiLibrary to be a top-level target?
 
     action $ do -- TODO: Add support for all rtsWays
         rtsLib    <- pkgLibraryFile $ rtsContext { way = vanilla  }
         rtsThrLib <- pkgLibraryFile $ rtsContext { way = threaded }
         need [ rtsLib, rtsThrLib ]
 
-    for_ allStages $ \stage ->
-        for_ (knownPackages \\ [rts, libffi]) $ \pkg -> action $ do
+    forM_ allStages $ \stage ->
+        forM_ (knownPackages \\ [rts, libffi]) $ \pkg -> action $ do
             let context = vanillaContext stage pkg
             activePackages <- interpretInContext context getPackages
             when (pkg `elem` activePackages) $
@@ -46,7 +46,7 @@ topLevelTargets = do
                 then do -- build a library
                     ways <- interpretInContext context getLibraryWays
                     libs <- mapM (pkgLibraryFile . Context stage pkg) ways
-                    docs <- interpretInContext context buildHaddock
+                    docs <- interpretInContext context $ buildHaddock flavour
                     need $ libs ++ [ pkgHaddockFile context | docs && stage == Stage1 ]
                 else do -- otherwise build a program
                     need [ fromJust $ programPath context ] -- TODO: drop fromJust
@@ -65,11 +65,11 @@ packageRules = do
     let contexts        = liftM3 Context        allStages knownPackages allWays
         vanillaContexts = liftM2 vanillaContext allStages knownPackages
 
-    for_ contexts $ mconcat
+    forM_ contexts $ mconcat
         [ Rules.Compile.compilePackage readPackageDb
         , Rules.Library.buildPackageLibrary ]
 
-    for_ vanillaContexts $ mconcat
+    forM_ vanillaContexts $ mconcat
         [ Rules.Data.buildPackageData
         , Rules.Dependencies.buildPackageDependencies readPackageDb
         , Rules.Documentation.buildPackageDocumentation

src/Rules/Actions.hs

@@ -17,9 +17,9 @@ import Oracles.ArgsHash
 import Oracles.DirectoryContent
 import Oracles.WindowsPath
 import Settings
-import Settings.Args
 import Settings.Builders.Ar
 import Target
+import UserSettings
 
 -- | Build a 'Target' with the right 'Builder' and command line arguments.
 -- Force a rebuild if the argument list has changed since the last build.

src/Rules/Cabal.hs

@@ -10,6 +10,7 @@ import Base
 import Expression
 import GHC
 import Settings
+import Settings.Paths
 
 cabalRules :: Rules ()
 cabalRules = do

src/Rules/Clean.hs

@@ -5,7 +5,7 @@ import Context
 import Package
 import Rules.Actions
 import Rules.Generate
-import Settings.Packages
+import Settings
 import Settings.Paths
 import Stage
 import UserSettings

src/Rules/Compile.hs

@@ -5,7 +5,7 @@ import Context
 import Expression
 import Oracles.Dependencies
 import Rules.Actions
-import Settings
+import Settings.Paths
 import Target
 
 compilePackage :: [(Resource, Int)] -> Context -> Rules ()

src/Rules/Data.hs

@@ -9,9 +9,10 @@ import Oracles.Dependencies
 import Rules.Actions
 import Rules.Generate
 import Rules.Libffi
-import Settings
 import Settings.Builders.Common
+import Settings.Paths
 import Target
+import UserSettings
 
 -- | Build @package-data.mk@ by using ghc-cabal utility to process .cabal files.
 buildPackageData :: Context -> Rules ()

src/Rules/Dependencies.hs

@@ -8,8 +8,9 @@ import Expression
 import Oracles.ModuleFiles
 import Oracles.PackageData
 import Rules.Actions
-import Settings
+import Settings.Paths
 import Target
+import UserSettings
 
 buildPackageDependencies :: [(Resource, Int)] -> Context -> Rules ()
 buildPackageDependencies rs context@Context {..} =

src/Rules/Documentation.hs

@@ -3,11 +3,13 @@ module Rules.Documentation (buildPackageDocumentation) where
 import Base
 import Context
 import Expression
+import Flavour
 import GHC
 import Oracles.ModuleFiles
 import Oracles.PackageData
 import Rules.Actions
 import Settings
+import Settings.Paths
 import Target
 
 haddockHtmlLib :: FilePath
@@ -38,7 +40,7 @@ buildPackageDocumentation context@Context {..} =
 
             -- Build Haddock documentation
             -- TODO: pass the correct way from Rules via Context
-            let haddockWay = if dynamicGhcPrograms then dynamic else vanilla
+            let haddockWay = if dynamicGhcPrograms flavour then dynamic else vanilla
             build $ Target (context {way = haddockWay}) Haddock srcs [file]
 
         when (package == haddock) $ haddockHtmlLib %> \_ -> do

src/Rules/Generate.hs

@@ -19,8 +19,9 @@ import Rules.Generators.GhcSplit
 import Rules.Generators.GhcVersionH
 import Rules.Generators.VersionHs
 import Rules.Libffi
-import Settings
+import Settings.Paths
 import Target
+import UserSettings
 
 installTargets :: [FilePath]
 installTargets = [ "inplace/lib/ghc-usage.txt"

src/Rules/Generators/ConfigHs.hs

@@ -2,11 +2,13 @@ module Rules.Generators.ConfigHs (generateConfigHs) where
 
 import Base
 import Expression
+import Flavour
 import GHC
 import Oracles.Config.Flag
 import Oracles.Config.Setting
-import Settings
 import Rules.Generators.Common
+import Settings
+import UserSettings
 
 generateConfigHs :: Expr String
 generateConfigHs = do
@@ -96,6 +98,6 @@ generateConfigHs = do
         , "cGhcThreaded :: Bool"
         , "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
         , "cGhcDebugged :: Bool"
-        , "cGhcDebugged = " ++ show ghcDebugged
+        , "cGhcDebugged = " ++ show (ghcDebugged flavour)
         , "cGhcRtsWithLibdw :: Bool"
         , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]

src/Rules/Library.hs

@@ -8,11 +8,14 @@ import qualified System.Directory as IO
 import Base
 import Context
 import Expression
+import Flavour
 import Oracles.PackageData
 import Rules.Actions
 import Rules.Gmp
 import Settings
+import Settings.Paths
 import Target
+import UserSettings
 
 buildPackageLibrary :: Context -> Rules ()
 buildPackageLibrary context@Context {..} = do
@@ -34,7 +37,7 @@ buildPackageLibrary context@Context {..} = do
         -- explicitly as this would needlessly bloat the Shake database).
         need $ cObjs ++ hObjs
 
-        split <- interpretInContext context splitObjects
+        split <- interpretInContext context $ splitObjects flavour
         splitObjs <- if not split then return hObjs else -- TODO: make clearer!
             concatForM hSrcs $ \src -> do
                 let splitPath = path -/- src ++ "_" ++ osuf way ++ "_split"

src/Rules/Program.hs

@@ -14,7 +14,9 @@ import Rules.Library
 import Rules.Wrappers.Ghc
 import Rules.Wrappers.GhcPkg
 import Settings
+import Settings.Paths
 import Target
+import UserSettings
 
 -- TODO: Move to buildRootPath, see #113.
 -- | Directory for wrapped binaries.

src/Rules/Register.hs

@@ -6,8 +6,8 @@ import Expression
 import GHC
 import Rules.Actions
 import Rules.Libffi
-import Settings
 import Settings.Packages.Rts
+import Settings.Paths
 import Target
 
 -- | Build package-data.mk by processing the .cabal file with ghc-cabal utility.

src/Rules/Test.hs

@@ -3,14 +3,14 @@ module Rules.Test (testRules) where
 import Base
 import Builder
 import Expression
+import Flavour
 import GHC
 import Oracles.Config.Flag
 import Oracles.Config.Setting
 import Oracles.WindowsPath
 import Rules.Actions
-import Settings.Packages
+import Settings
 import Target
-import UserSettings
 
 -- TODO: clean up after testing
 testRules :: Rules ()
@@ -43,7 +43,7 @@ testRules = do
             , "-e", "config.speed=2"
             , "-e", "ghc_compiler_always_flags=" ++ show "-fforce-recomp -dcore-lint -dcmm-lint -dno-debug-output -no-user-package-db -rtsopts"
             , "-e", "ghc_with_native_codegen=" ++ show ghcWithNativeCodeGenInt
-            , "-e", "ghc_debugged=" ++ yesNo ghcDebugged
+            , "-e", "ghc_debugged=" ++ yesNo (ghcDebugged flavour)
             , "-e", "ghc_with_vanilla=1" -- TODO: do we always build vanilla?
             , "-e", "ghc_with_dynamic=0" -- TODO: support dynamic
             , "-e", "ghc_with_profiling=0" -- TODO: support profiling