Refactor command line arguments and flavours

* Get rid of unsafePerformIO using shakeExtra
* Move diagnostic info utilities to the library

See #347

hadrian.cabal

@@ -20,7 +20,7 @@ executable hadrian
                        , src
     other-modules:       Base
                        , Builder
-                       , CmdLineFlag
+                       , CommandLine
                        , Context
                        , Environment
                        , Expression

src/CmdLineFlag.hs → src/CommandLine.hs

-module CmdLineFlag (
-    putCmdLineFlags, cmdFlags, cmdBuildHaddock, cmdFlavour, cmdIntegerSimple,
-    cmdProgressColour, cmdProgressInfo, ProgressInfo (..), cmdSkipConfigure,
-    cmdSplitObjects
+module CommandLine (
+    optDescrs, cmdLineArgsMap, cmdBuildHaddock, cmdFlavour, cmdIntegerSimple,
+    cmdProgressColour, cmdProgressInfo, cmdSkipConfigure, cmdSplitObjects
     ) where
 
-import Data.IORef
+import Data.Dynamic
+import Data.Either
+import qualified Data.HashMap.Strict as Map
 import Data.List.Extra
+import Development.Shake hiding (Normal)
 import Hadrian.Utilities
 import System.Console.GetOpt
-import System.IO.Unsafe
+import System.Environment
 
--- | 'CmdLineFlag.Untracked' is a collection of flags that can be passed via the
--- command line. These flags are not tracked, that is they do not force any
--- build rules to be rurun.
-data Untracked = Untracked
+-- | All arguments that can be passed to Hadrian via the command line.
+data CommandLineArgs = CommandLineArgs
     { buildHaddock   :: Bool
     , flavour        :: Maybe String
     , integerSimple  :: Bool
@@ -23,11 +23,9 @@ data Untracked = Untracked
     , splitObjects   :: Bool }
     deriving (Eq, Show)
 
-data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show)
-
--- | Default values for 'CmdLineFlag.Untracked'.
-defaultUntracked :: Untracked
-defaultUntracked = Untracked
+-- | Default values for 'CommandLineArgs'.
+defaultCommandLineArgs :: CommandLineArgs
+defaultCommandLineArgs = CommandLineArgs
     { buildHaddock   = False
     , flavour        = Nothing
     , integerSimple  = False
@@ -36,16 +34,16 @@ defaultUntracked = Untracked
     , skipConfigure  = False
     , splitObjects   = False }
 
-readBuildHaddock :: Either String (Untracked -> Untracked)
+readBuildHaddock :: Either String (CommandLineArgs -> CommandLineArgs)
 readBuildHaddock = Right $ \flags -> flags { buildHaddock = True }
 
-readFlavour :: Maybe String -> Either String (Untracked -> Untracked)
+readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
 readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms }
 
-readIntegerSimple :: Either String (Untracked -> Untracked)
+readIntegerSimple :: Either String (CommandLineArgs -> CommandLineArgs)
 readIntegerSimple = Right $ \flags -> flags { integerSimple = True }
 
-readProgressColour :: Maybe String -> Either String (Untracked -> Untracked)
+readProgressColour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
 readProgressColour ms =
     maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
   where
@@ -54,10 +52,10 @@ readProgressColour ms =
     go "auto"    = Just Auto
     go "always"  = Just Always
     go _         = Nothing
-    set :: UseColour -> Untracked -> Untracked
+    set :: UseColour -> CommandLineArgs -> CommandLineArgs
     set flag flags = flags { progressColour = flag }
 
-readProgressInfo :: Maybe String -> Either String (Untracked -> Untracked)
+readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
 readProgressInfo ms =
     maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
   where
@@ -67,17 +65,18 @@ readProgressInfo ms =
     go "normal"  = Just Normal
     go "unicorn" = Just Unicorn
     go _         = Nothing
-    set :: ProgressInfo -> Untracked -> Untracked
+    set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs
     set flag flags = flags { progressInfo = flag }
 
-readSkipConfigure :: Either String (Untracked -> Untracked)
+readSkipConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
 readSkipConfigure = Right $ \flags -> flags { skipConfigure = True }
 
-readSplitObjects :: Either String (Untracked -> Untracked)
+readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
 readSplitObjects = Right $ \flags -> flags { splitObjects = True }
 
-cmdFlags :: [OptDescr (Either String (Untracked -> Untracked))]
-cmdFlags =
+-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
+optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
+optDescrs =
     [ Option [] ["flavour"] (OptArg readFlavour "FLAVOUR")
       "Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)."
     , Option [] ["haddock"] (NoArg readBuildHaddock)
@@ -93,36 +92,37 @@ cmdFlags =
     , Option [] ["split-objects"] (NoArg readSplitObjects)
       "Generate split objects (requires a full clean rebuild)." ]
 
--- TODO: Avoid unsafePerformIO by using shakeExtra.
-{-# NOINLINE cmdLineFlags #-}
-cmdLineFlags :: IORef Untracked
-cmdLineFlags = unsafePerformIO $ newIORef defaultUntracked
+-- | 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)
+    return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
+           $ insertExtra (progressInfo   args) -- Accessed by Hadrian.Utilities
+           $ insertExtra args Map.empty
 
-putCmdLineFlags :: [Untracked -> Untracked] -> IO ()
-putCmdLineFlags flags = modifyIORef cmdLineFlags (\f -> foldl (flip id) f flags)
+cmdLineArgs :: Action CommandLineArgs
+cmdLineArgs = userSetting defaultCommandLineArgs
 
--- TODO: Avoid unsafePerformIO by using shakeExtra.
-{-# NOINLINE getCmdLineFlags #-}
-getCmdLineFlags :: Untracked
-getCmdLineFlags = unsafePerformIO $ readIORef cmdLineFlags
+cmdBuildHaddock :: Action Bool
+cmdBuildHaddock = buildHaddock <$> cmdLineArgs
 
-cmdBuildHaddock :: Bool
-cmdBuildHaddock = buildHaddock getCmdLineFlags
+cmdFlavour :: Action (Maybe String)
+cmdFlavour = flavour <$> cmdLineArgs
 
-cmdFlavour :: Maybe String
-cmdFlavour = flavour getCmdLineFlags
+cmdIntegerSimple :: Action Bool
+cmdIntegerSimple = integerSimple <$> cmdLineArgs
 
-cmdIntegerSimple :: Bool
-cmdIntegerSimple = integerSimple getCmdLineFlags
+cmdProgressColour :: Action UseColour
+cmdProgressColour = progressColour <$> cmdLineArgs
 
-cmdProgressColour :: UseColour
-cmdProgressColour = progressColour getCmdLineFlags
+cmdProgressInfo :: Action ProgressInfo
+cmdProgressInfo = progressInfo <$> cmdLineArgs
 
-cmdProgressInfo :: ProgressInfo
-cmdProgressInfo = progressInfo getCmdLineFlags
+cmdSkipConfigure :: Action Bool
+cmdSkipConfigure = skipConfigure <$> cmdLineArgs
 
-cmdSplitObjects :: Bool
-cmdSplitObjects = splitObjects getCmdLineFlags
+cmdSplitObjects :: Action Bool
+cmdSplitObjects = splitObjects <$> cmdLineArgs
 
-cmdSkipConfigure :: Bool
-cmdSkipConfigure = skipConfigure getCmdLineFlags

src/Flavour.hs

@@ -9,15 +9,15 @@ import Expression
 -- * @Predicate@: a flag whose value can depend on the build environment and
 -- on the current build target.
 data Flavour = Flavour
-    { name               :: String    -- ^ Flavour name, to set from command line.
-    , args               :: Args      -- ^ Use these command line arguments.
-    , packages           :: Packages  -- ^ Build these packages.
-    , integerLibrary     :: Package   -- ^ Either 'integerGmp' or 'integerSimple'.
-    , 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.
+    { name               :: String         -- ^ Flavour name, to set from command line.
+    , args               :: Args           -- ^ Use these command line arguments.
+    , packages           :: Packages       -- ^ Build these packages.
+    , integerLibrary     :: Action Package -- ^ Either 'integerGmp' or 'integerSimple'.
+    , 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/Hadrian/Utilities.hs

 module Hadrian.Utilities (
-
     -- * List manipulation
     fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll,
 
@@ -9,19 +8,30 @@ module Hadrian.Utilities (
     -- * FilePath manipulation
     unifyPath, (-/-), matchVersionedFilePath,
 
-    -- * Miscellaneous
-    UseColour (..), putColoured
+    -- * Accessing Shake's type-indexed map
+    insertExtra, userSetting,
+
+    -- * Diagnostic info
+    UseColour (..), putColoured, BuildProgressColour (..), putBuild,
+    SuccessColour (..), putSuccess, ProgressInfo (..),
+    putProgressInfo, renderAction, renderProgram, renderLibrary, renderBox,
+    renderUnicorn
     ) where
 
 import Control.Monad
 import Data.Char
+import Data.Dynamic
+import Data.HashMap.Strict (HashMap)
 import Data.List.Extra
-import Development.Shake
+import Data.Maybe
+import Development.Shake hiding (Normal)
 import Development.Shake.FilePath
 import System.Console.ANSI
 import System.Info.Extra
 import System.IO
 
+import qualified Data.HashMap.Strict as Map
+
 -- | Extract a value from a singleton list, or terminate with an error message
 -- if the list does not contain exactly one value.
 fromSingleton :: String -> [a] -> a
@@ -109,11 +119,24 @@ matchVersionedFilePath prefix suffix filePath =
         Nothing      -> False
         Just version -> all (\c -> isDigit c || c == '-' || c == '.') version
 
-data UseColour = Never | Auto | Always deriving (Eq, Show)
+-- | Insert a value into Shake's type-indexed map.
+insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
+insertExtra value = Map.insert (typeOf value) (toDyn value)
+
+-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
+-- setting is not found, return the provided default value instead.
+userSetting :: Typeable a => a -> Action a
+userSetting defaultValue = do
+    extra <- shakeExtra <$> getShakeOptions
+    let maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra
+    return $ fromMaybe defaultValue maybeValue
+
+data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)
 
 -- | A more colourful version of Shake's 'putNormal'.
-putColoured :: UseColour -> ColorIntensity -> Color -> String -> Action ()
-putColoured useColour intensity colour msg = do
+putColoured :: ColorIntensity -> Color -> String -> Action ()
+putColoured intensity colour msg = do
+    useColour <- userSetting Never
     supported <- liftIO $ hSupportsANSI stdout
     let c Never  = False
         c Auto   = supported || isWindows -- Colours do work on Windows
@@ -121,3 +144,126 @@ putColoured useColour intensity colour msg = do
     when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour]
     putNormal msg
     when (c useColour) . liftIO $ setSGR [] >> hFlush stdout
+
+newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color)
+    deriving Typeable
+
+-- | Default 'BuildProgressColour'.
+magenta :: BuildProgressColour
+magenta = BuildProgressColour (Dull, Magenta)
+
+-- | Print a build progress message (e.g. executing a build command).
+putBuild :: String -> Action ()
+putBuild msg = do
+    BuildProgressColour (intensity, colour) <- userSetting magenta
+    putColoured intensity colour msg
+
+newtype SuccessColour = SuccessColour (ColorIntensity, Color)
+    deriving Typeable
+
+-- | Default 'SuccessColour'.
+green :: SuccessColour
+green = SuccessColour (Dull, Green)
+
+-- | Print a success message (e.g. a package is built successfully).
+putSuccess :: String -> Action ()
+putSuccess msg = do
+    SuccessColour (intensity, colour) <- userSetting green
+    putColoured intensity colour msg
+
+data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)
+
+-- | Version of 'putBuild' controlled by @--progress-info@ command line flag.
+putProgressInfo :: String -> Action ()
+putProgressInfo msg = do
+    progressInfo <- userSetting None
+    when (progressInfo /= None) $ putBuild msg
+
+-- | Render an action.
+renderAction :: String -> FilePath -> FilePath -> Action String
+renderAction what input output = do
+    progressInfo <- userSetting Normal
+    return $ case progressInfo of
+        None    -> ""
+        Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
+        Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
+        Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
+  where
+    i = unifyPath input
+    o = unifyPath output
+
+-- | Render the successful build of a program.
+renderProgram :: String -> String -> String -> String
+renderProgram name bin synopsis = renderBox [ "Successfully built program " ++ name
+                                            , "Executable: " ++ bin
+                                            , "Program synopsis: " ++ synopsis ++ "."]
+
+-- | Render the successful build of a library.
+renderLibrary :: String -> String -> String -> String
+renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
+                                            , "Library: " ++ lib
+                                            , "Library synopsis: " ++ synopsis ++ "."]
+
+-- | Render the given set of lines in an ASCII box. The minimum width and
+-- whether to use Unicode symbols are hardcoded in the function's body.
+--
+-- >>> renderBox (words "lorem ipsum")
+-- /----------\
+-- | lorem    |
+-- | ipsum    |
+-- \----------/
+renderBox :: [String] -> String
+renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
+  where
+    -- Minimum total width of the box in characters
+    minimumBoxWidth = 32
+
+    -- TODO: Make this setting configurable? Setting to True by default seems
+    -- to work poorly with many fonts.
+    useUnicode = False
+
+    -- Characters to draw the box
+    (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
+        | useUnicode = ('─', '│', '╭',  '╮', '╰', '╯', ' ')
+        | otherwise  = ('-', '|', '/', '\\', '\\', '/', ' ')
+
+    -- Box width, taking minimum desired length and content into account.
+    -- The -4 is for the beginning and end pipe/padding symbols, as
+    -- in "| xxx |".
+    boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
+      where
+        maxContentLength = maximum (map length ls)
+
+    renderLine l = concat
+        [ [pipe, padding]
+        , padToLengthWith boxContentWidth padding l
+        , [padding, pipe] ]
+      where
+        padToLengthWith n filler x = x ++ replicate (n - length x) filler
+
+    (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
+                       , botLeft : dashes ++ [botRight] )
+      where
+        -- +1 for each non-dash (= corner) char
+        dashes = replicate (boxContentWidth + 2) dash
+
+-- | Render the given set of lines next to our favorite unicorn Robert.
+renderUnicorn :: [String] -> String
+renderUnicorn ls =
+    unlines $ take (max (length ponyLines) (length boxLines)) $
+        zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
+  where
+    ponyLines :: [String]
+    ponyLines = [ "                   ,;,,;'"
+                , "                  ,;;'(    Robert the spitting unicorn"
+                , "       __       ,;;' ' \\   wants you to know"
+                , "     /'  '\\'~~'~' \\ /'\\.)  that a task      "
+                , "  ,;(      )    /  |.  /   just finished!   "
+                , " ,;' \\    /-.,,(   ) \\                      "
+                , " ^    ) /       ) / )|     Almost there!    "
+                , "      ||        ||  \\)                      "
+                , "      (_\\       (_\\                         " ]
+    ponyPadding :: String
+    ponyPadding = "                                            "
+    boxLines :: [String]
+    boxLines = ["", "", ""] ++ (lines . renderBox $ ls)

src/Main.hs

 module Main (main) where
 
 import Development.Shake
+import Hadrian.Utilities
 
-import qualified CmdLineFlag
+import qualified CommandLine
 import qualified Environment
 import qualified Rules
 import qualified Rules.Clean
@@ -11,28 +12,37 @@ import qualified Rules.SourceDist
 import qualified Rules.Selftest
 import qualified Rules.Test
 import qualified Settings.Path
+import qualified UserSettings
 
 main :: IO ()
-main = shakeArgsWith options CmdLineFlag.cmdFlags $ \cmdLineFlags targets -> do
-    CmdLineFlag.putCmdLineFlags cmdLineFlags
-    Environment.setupEnvironment
-    return . Just $ if null targets
-                    then rules
-                    else want targets >> withoutActions rules
-  where
-    rules :: Rules ()
-    rules = do
-        Rules.buildRules
-        Rules.Clean.cleanRules
-        Rules.Install.installRules
-        Rules.oracleRules
-        Rules.Selftest.selftestRules
-        Rules.SourceDist.sourceDistRules
-        Rules.Test.testRules
-        Rules.topLevelTargets
-    options :: ShakeOptions
-    options = shakeOptions
-        { shakeChange   = ChangeModtimeAndDigest
-        , shakeFiles    = Settings.Path.shakeFilesPath
-        , shakeProgress = progressSimple
-        , shakeTimings  = True }
+main = do
+    -- Provide access to command line arguments and some user settings through
+    -- Shake's type-indexed map 'shakeExtra'.
+    argsMap <- CommandLine.cmdLineArgsMap
+    let extra = insertExtra UserSettings.buildProgressColour
+              $ insertExtra UserSettings.successColour argsMap
+
+        options :: ShakeOptions
+        options = shakeOptions
+            { shakeChange   = ChangeModtimeAndDigest
+            , shakeFiles    = Settings.Path.shakeFilesPath
+            , shakeProgress = progressSimple
+            , shakeTimings  = True
+            , shakeExtra    = extra }
+
+        rules :: Rules ()
+        rules = do
+            Rules.buildRules
+            Rules.Clean.cleanRules
+            Rules.Install.installRules
+            Rules.oracleRules
+            Rules.Selftest.selftestRules
+            Rules.SourceDist.sourceDistRules
+            Rules.Test.testRules
+            Rules.topLevelTargets
+
+    shakeArgsWith options CommandLine.optDescrs $ \_ targets -> do
+        Environment.setupEnvironment
+        return . Just $ if null targets
+                        then rules
+                        else want targets >> withoutActions rules

src/Rules.hs

@@ -57,13 +57,13 @@ packageTargets stage pkg = do
         then do -- Collect all targets of a library package.
             ways <- interpretInContext context getLibraryWays
             libs <- mapM (pkgLibraryFile . Context stage pkg) ways
-            docs <- interpretInContext context $ buildHaddock flavour
+            docs <- interpretInContext context =<< buildHaddock <$> flavour
             more <- libraryTargets context
             return $ [ pkgSetupConfigFile context | nonCabalContext context ]
                   ++ [ pkgHaddockFile     context | docs && stage == Stage1 ]
                   ++ libs ++ more
         else -- The only target of a program package is the executable.
-            maybeToList <$> programPath (programContext stage pkg)
+            fmap maybeToList . programPath =<< programContext stage pkg
 
 packageRules :: Rules ()
 packageRules = do
@@ -77,24 +77,21 @@ packageRules = do
 
     let contexts        = liftM3 Context        allStages knownPackages allWays
         vanillaContexts = liftM2 vanillaContext allStages knownPackages
-        programContexts = liftM2 programContext allStages knownPackages
 
     forM_ contexts $ mconcat
         [ Rules.Compile.compilePackage readPackageDb
         , Rules.Library.buildPackageLibrary ]
 
     let dynamicContexts = liftM3 Context [Stage1 ..] knownPackages [dynamic]
-
     forM_ dynamicContexts Rules.Library.buildDynamicLib
 
-    forM_ programContexts $ Rules.Program.buildProgram readPackageDb
-
     forM_ vanillaContexts $ mconcat
         [ Rules.Data.buildPackageData
         , Rules.Dependencies.buildPackageDependencies readPackageDb
         , Rules.Documentation.buildPackageDocumentation
         , Rules.Library.buildPackageGhciLibrary
         , Rules.Generate.generatePackageCode
+        , Rules.Program.buildProgram readPackageDb
         , Rules.Register.registerPackage writePackageDb ]
 
 buildRules :: Rules ()

src/Rules/Cabal.hs

@@ -11,7 +11,6 @@ import Base
 import GHC
 import Settings
 import Settings.Path
-import UserSettings
 
 cabalRules :: Rules ()
 cabalRules = do

src/Rules/Configure.hs

@@ -3,17 +3,17 @@ module Rules.Configure (configureRules) where
 import qualified System.Info as System
 
 import Base
-import CmdLineFlag
+import CommandLine
 import Context
 import GHC
 import Target
-import UserSettings
 import Utilities
 
 configureRules :: Rules ()
 configureRules = do
     [configFile, "settings", configH] &%> \outs -> do
-        if cmdSkipConfigure
+        skip <- cmdSkipConfigure
+        if skip
         then unlessM (doesFileExist configFile) $
             error $ "Configuration file " ++ configFile ++ " is missing."
                 ++ "\nRun the configure script manually or do not use the "
@@ -29,7 +29,8 @@ configureRules = do
             build $ target context (Configure ".") srcs outs
 
     ["configure", configH <.> "in"] &%> \_ -> do
-        if cmdSkipConfigure
+        skip <- cmdSkipConfigure
+        if skip
         then unlessM (doesFileExist "configure") $
             error $ "The configure script is missing.\nRun the boot script"
                 ++ " manually or do not use the --skip-configure flag."

src/Rules/Data.hs

@@ -8,7 +8,6 @@ import Oracles.Setting
 import Rules.Generate
 import Settings.Path
 import Target
-import UserSettings
 import Utilities
 
 -- | Build @package-data.mk@ by using ghc-cabal utility to process .cabal files.

src/Rules/Documentation.hs

@@ -32,7 +32,8 @@ buildPackageDocumentation context@Context {..} =
 
             -- Build Haddock documentation
             -- TODO: pass the correct way from Rules via Context
-            let haddockWay = if dynamicGhcPrograms flavour then dynamic else vanilla
+            dynamicPrograms <- dynamicGhcPrograms <$> flavour
+            let haddockWay = if dynamicPrograms then dynamic else vanilla
             build $ target (context {way = haddockWay}) Haddock srcs [file]
 
         when (package == haddock) $ haddockHtmlLib %> \_ -> do

src/Rules/Generate.hs

@@ -15,7 +15,6 @@ import Rules.Libffi
 import Settings
 import Settings.Path
 import Target
-import UserSettings
 import Utilities
 
 -- | Track this file to rebuild generated files whenever it changes.
@@ -58,12 +57,13 @@ derivedConstantsDependencies = fmap (generatedPath -/-)
 
 compilerDependencies :: Expr [FilePath]
 compilerDependencies = do
-    stage <- getStage
+    stage  <- getStage
+    intLib <- expr (integerLibrary =<< flavour)
     let path = buildPath $ vanillaContext stage compiler
     mconcat [ return [platformH stage]
             , return includesDependencies
             , return derivedConstantsDependencies
-            , notStage0 ? integerLibrary flavour == integerGmp ? return [gmpLibraryH]
+            , notStage0 ? intLib == integerGmp ? return [gmpLibraryH]
             , notStage0 ? return libffiDependencies
             , return $ fmap (path -/-)
                   [ "primop-can-fail.hs-incl"
@@ -260,10 +260,12 @@ generateConfigHs = do
     cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
     cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
     cBooterVersion      <- getSetting GhcVersion
+    intLib              <- expr (integerLibrary =<< flavour)
+    debugged            <- ghcDebugged    <$> expr flavour
     let cIntegerLibraryType
-            | integerLibrary flavour == integerGmp    = "IntegerGMP"
-            | integerLibrary flavour == integerSimple = "IntegerSimple"
-            | otherwise = error $ "Unknown integer library: " ++ integerLibraryName
+            | intLib == integerGmp    = "IntegerGMP"
+            | intLib == integerSimple = "IntegerSimple"
+            | otherwise = error $ "Unknown integer library: " ++ pkgNameString intLib
     cSupportsSplitObjs         <- expr $ yesNo <$> supportsSplitObjects
     cGhcWithInterpreter        <- expr $ yesNo <$> ghcWithInterpreter