Refactor command line arguments and flavours
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 14 Aug 2017 22:12:52 +0000 (23:12 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 14 Aug 2017 22:12:52 +0000 (23:12 +0100)
* Get rid of unsafePerformIO using shakeExtra
* Move diagnostic info utilities to the library

See #347

28 files changed:
hadrian.cabal
src/CmdLineFlag.hs [deleted file]
src/CommandLine.hs [new file with mode: 0644]
src/Flavour.hs
src/Hadrian/Utilities.hs
src/Main.hs
src/Rules.hs
src/Rules/Cabal.hs
src/Rules/Configure.hs
src/Rules/Data.hs
src/Rules/Documentation.hs
src/Rules/Generate.hs
src/Rules/Gmp.hs
src/Rules/Install.hs
src/Rules/Library.hs
src/Rules/Program.hs
src/Rules/Register.hs
src/Rules/Selftest.hs
src/Rules/SourceDist.hs
src/Rules/Test.hs
src/Settings.hs
src/Settings/Builders/Ghc.hs
src/Settings/Builders/GhcCabal.hs
src/Settings/Default.hs
src/Settings/Packages/Base.hs
src/Settings/Packages/Compiler.hs
src/UserSettings.hs
src/Utilities.hs

index 869fcc7..b9de806 100644 (file)
@@ -20,7 +20,7 @@ executable hadrian
                        , src
     other-modules:       Base
                        , Builder
-                       , CmdLineFlag
+                       , CommandLine
                        , Context
                        , Environment
                        , Expression
diff --git a/src/CmdLineFlag.hs b/src/CmdLineFlag.hs
deleted file mode 100644 (file)
index ff35f1f..0000000
+++ /dev/null
@@ -1,128 +0,0 @@
-module CmdLineFlag (
-    putCmdLineFlags, cmdFlags, cmdBuildHaddock, cmdFlavour, cmdIntegerSimple,
-    cmdProgressColour, cmdProgressInfo, ProgressInfo (..), cmdSkipConfigure,
-    cmdSplitObjects
-    ) where
-
-import Data.IORef
-import Data.List.Extra
-import Hadrian.Utilities
-import System.Console.GetOpt
-import System.IO.Unsafe
-
--- | '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
-    { buildHaddock   :: Bool
-    , flavour        :: Maybe String
-    , integerSimple  :: Bool
-    , progressColour :: UseColour
-    , progressInfo   :: ProgressInfo
-    , skipConfigure  :: Bool
-    , splitObjects   :: Bool }
-    deriving (Eq, Show)
-
-data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show)
-
--- | Default values for 'CmdLineFlag.Untracked'.
-defaultUntracked :: Untracked
-defaultUntracked = Untracked
-    { buildHaddock   = False
-    , flavour        = Nothing
-    , integerSimple  = False
-    , progressColour = Auto
-    , progressInfo   = Normal
-    , skipConfigure  = False
-    , splitObjects   = False }
-
-readBuildHaddock :: Either String (Untracked -> Untracked)
-readBuildHaddock = Right $ \flags -> flags { buildHaddock = True }
-
-readFlavour :: Maybe String -> Either String (Untracked -> Untracked)
-readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms }
-
-readIntegerSimple :: Either String (Untracked -> Untracked)
-readIntegerSimple = Right $ \flags -> flags { integerSimple = True }
-
-readProgressColour :: Maybe String -> Either String (Untracked -> Untracked)
-readProgressColour ms =
-    maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
-  where
-    go :: String -> Maybe UseColour
-    go "never"   = Just Never
-    go "auto"    = Just Auto
-    go "always"  = Just Always
-    go _         = Nothing
-    set :: UseColour -> Untracked -> Untracked
-    set flag flags = flags { progressColour = flag }
-
-readProgressInfo :: Maybe String -> Either String (Untracked -> Untracked)
-readProgressInfo ms =
-    maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
-  where
-    go :: String -> Maybe ProgressInfo
-    go "none"    = Just None
-    go "brief"   = Just Brief
-    go "normal"  = Just Normal
-    go "unicorn" = Just Unicorn
-    go _         = Nothing
-    set :: ProgressInfo -> Untracked -> Untracked
-    set flag flags = flags { progressInfo = flag }
-
-readSkipConfigure :: Either String (Untracked -> Untracked)
-readSkipConfigure = Right $ \flags -> flags { skipConfigure = True }
-
-readSplitObjects :: Either String (Untracked -> Untracked)
-readSplitObjects = Right $ \flags -> flags { splitObjects = True }
-
-cmdFlags :: [OptDescr (Either String (Untracked -> Untracked))]
-cmdFlags =
-    [ Option [] ["flavour"] (OptArg readFlavour "FLAVOUR")
-      "Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)."
-    , Option [] ["haddock"] (NoArg readBuildHaddock)
-      "Generate Haddock documentation."
-    , Option [] ["integer-simple"] (NoArg readIntegerSimple)
-      "Build GHC with integer-simple library."
-    , Option [] ["progress-colour"] (OptArg readProgressColour "MODE")
-      "Use colours in progress info (Never, Auto or Always)."
-    , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
-      "Progress info style (None, Brief, Normal or Unicorn)."
-    , Option [] ["skip-configure"] (NoArg readSkipConfigure)
-      "Skip the boot and configure scripts (if you want to run them manually)."
-    , 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
-
-putCmdLineFlags :: [Untracked -> Untracked] -> IO ()
-putCmdLineFlags flags = modifyIORef cmdLineFlags (\f -> foldl (flip id) f flags)
-
--- TODO: Avoid unsafePerformIO by using shakeExtra.
-{-# NOINLINE getCmdLineFlags #-}
-getCmdLineFlags :: Untracked
-getCmdLineFlags = unsafePerformIO $ readIORef cmdLineFlags
-
-cmdBuildHaddock :: Bool
-cmdBuildHaddock = buildHaddock getCmdLineFlags
-
-cmdFlavour :: Maybe String
-cmdFlavour = flavour getCmdLineFlags
-
-cmdIntegerSimple :: Bool
-cmdIntegerSimple = integerSimple getCmdLineFlags
-
-cmdProgressColour :: UseColour
-cmdProgressColour = progressColour getCmdLineFlags
-
-cmdProgressInfo :: ProgressInfo
-cmdProgressInfo = progressInfo getCmdLineFlags
-
-cmdSplitObjects :: Bool
-cmdSplitObjects = splitObjects getCmdLineFlags
-
-cmdSkipConfigure :: Bool
-cmdSkipConfigure = skipConfigure getCmdLineFlags
diff --git a/src/CommandLine.hs b/src/CommandLine.hs
new file mode 100644 (file)
index 0000000..18ce2ec
--- /dev/null
@@ -0,0 +1,128 @@
+module CommandLine (
+    optDescrs, cmdLineArgsMap, cmdBuildHaddock, cmdFlavour, cmdIntegerSimple,
+    cmdProgressColour, cmdProgressInfo, cmdSkipConfigure, cmdSplitObjects
+    ) where
+
+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.Environment
+
+-- | All arguments that can be passed to Hadrian via the command line.
+data CommandLineArgs = CommandLineArgs
+    { buildHaddock   :: Bool
+    , flavour        :: Maybe String
+    , integerSimple  :: Bool
+    , progressColour :: UseColour
+    , progressInfo   :: ProgressInfo
+    , skipConfigure  :: Bool
+    , splitObjects   :: Bool }
+    deriving (Eq, Show)
+
+-- | Default values for 'CommandLineArgs'.
+defaultCommandLineArgs :: CommandLineArgs
+defaultCommandLineArgs = CommandLineArgs
+    { buildHaddock   = False
+    , flavour        = Nothing
+    , integerSimple  = False
+    , progressColour = Auto
+    , progressInfo   = Normal
+    , skipConfigure  = False
+    , splitObjects   = False }
+
+readBuildHaddock :: Either String (CommandLineArgs -> CommandLineArgs)
+readBuildHaddock = Right $ \flags -> flags { buildHaddock = True }
+
+readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms }
+
+readIntegerSimple :: Either String (CommandLineArgs -> CommandLineArgs)
+readIntegerSimple = Right $ \flags -> flags { integerSimple = True }
+
+readProgressColour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readProgressColour ms =
+    maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
+  where
+    go :: String -> Maybe UseColour
+    go "never"   = Just Never
+    go "auto"    = Just Auto
+    go "always"  = Just Always
+    go _         = Nothing
+    set :: UseColour -> CommandLineArgs -> CommandLineArgs
+    set flag flags = flags { progressColour = flag }
+
+readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readProgressInfo ms =
+    maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
+  where
+    go :: String -> Maybe ProgressInfo
+    go "none"    = Just None
+    go "brief"   = Just Brief
+    go "normal"  = Just Normal
+    go "unicorn" = Just Unicorn
+    go _         = Nothing
+    set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs
+    set flag flags = flags { progressInfo = flag }
+
+readSkipConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
+readSkipConfigure = Right $ \flags -> flags { skipConfigure = True }
+
+readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
+readSplitObjects = Right $ \flags -> flags { splitObjects = True }
+
+-- | 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)
+      "Generate Haddock documentation."
+    , Option [] ["integer-simple"] (NoArg readIntegerSimple)
+      "Build GHC with integer-simple library."
+    , Option [] ["progress-colour"] (OptArg readProgressColour "MODE")
+      "Use colours in progress info (Never, Auto or Always)."
+    , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
+      "Progress info style (None, Brief, Normal or Unicorn)."
+    , Option [] ["skip-configure"] (NoArg readSkipConfigure)
+      "Skip the boot and configure scripts (if you want to run them manually)."
+    , Option [] ["split-objects"] (NoArg readSplitObjects)
+      "Generate split objects (requires a full clean rebuild)." ]
+
+-- | 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
+
+cmdLineArgs :: Action CommandLineArgs
+cmdLineArgs = userSetting defaultCommandLineArgs
+
+cmdBuildHaddock :: Action Bool
+cmdBuildHaddock = buildHaddock <$> cmdLineArgs
+
+cmdFlavour :: Action (Maybe String)
+cmdFlavour = flavour <$> cmdLineArgs
+
+cmdIntegerSimple :: Action Bool
+cmdIntegerSimple = integerSimple <$> cmdLineArgs
+
+cmdProgressColour :: Action UseColour
+cmdProgressColour = progressColour <$> cmdLineArgs
+
+cmdProgressInfo :: Action ProgressInfo
+cmdProgressInfo = progressInfo <$> cmdLineArgs
+
+cmdSkipConfigure :: Action Bool
+cmdSkipConfigure = skipConfigure <$> cmdLineArgs
+
+cmdSplitObjects :: Action Bool
+cmdSplitObjects = splitObjects <$> cmdLineArgs
+
index 3283eda..737b201 100644 (file)
@@ -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.
index bf9a9ac..3eea2ba 100644 (file)
@@ -1,5 +1,4 @@
 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)
index 6843140..22a2270 100644 (file)
@@ -1,8 +1,9 @@
 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
index 149789f..d55a578 100644 (file)
@@ -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 ()
index 71f68e8..ddfd0f2 100644 (file)
@@ -11,7 +11,6 @@ import Base
 import GHC
 import Settings
 import Settings.Path
-import UserSettings
 
 cabalRules :: Rules ()
 cabalRules = do
index af79967..d58aac6 100644 (file)
@@ -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."
index ff18a12..de1a991 100644 (file)
@@ -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.
index b59b09f..842eb4c 100644 (file)
@@ -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
index 7b7d27e..b02b654 100644 (file)
@@ -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
     cGhcWithNativeCodeGen      <- expr $ yesNo <$> ghcWithNativeCodeGen
@@ -311,7 +313,7 @@ generateConfigHs = do
         , "cStage                :: String"
         , "cStage                = show (STAGE :: Int)"
         , "cIntegerLibrary       :: String"
-        , "cIntegerLibrary       = " ++ show integerLibraryName
+        , "cIntegerLibrary       = " ++ show (pkgNameString intLib)
         , "cIntegerLibraryType   :: IntegerLibrary"
         , "cIntegerLibraryType   = " ++ cIntegerLibraryType
         , "cSupportsSplitObjs    :: String"
@@ -337,7 +339,7 @@ generateConfigHs = do
         , "cGhcThreaded :: Bool"
         , "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
         , "cGhcDebugged :: Bool"
-        , "cGhcDebugged = " ++ show (ghcDebugged flavour)
+        , "cGhcDebugged = " ++ show debugged
         , "cGhcRtsWithLibdw :: Bool"
         , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
 
index c6d18b4..765dbeb 100644 (file)
@@ -6,7 +6,6 @@ import Oracles.Setting
 import Settings.Packages.IntegerGmp
 import Settings.Path
 import Target
-import UserSettings
 import Utilities
 
 gmpBase :: FilePath
index 4b24ca2..7d5245c 100644 (file)
@@ -76,8 +76,8 @@ installLibExecs = do
     installDirectory (destDir ++ libExecDir)
     forM_ installBinPkgs $ \pkg -> do
         withLatestBuildStage pkg $ \stage -> do
-            let context = programContext stage pkg
-                bin     = inplaceLibBinPath -/- programName context <.> exe
+            context <- programContext stage pkg
+            let bin = inplaceLibBinPath -/- programName context <.> exe
             installProgram bin (destDir ++ libExecDir)
             when (pkg == ghc) $ do
                 moveFile (destDir ++ libExecDir -/- programName context <.> exe)
@@ -95,7 +95,7 @@ installBins = do
         copyDirectoryContents matchAll (destDir ++ libDir -/- "bin") (destDir ++ binDir)
     unless win $ forM_ installBinPkgs $ \pkg ->
         withLatestBuildStage pkg $ \stage -> do
-            let context = programContext stage pkg
+            context <- programContext stage pkg
             version <- setting ProjectVersion
             -- Name of the binary file
             let binName = if pkg == ghc
index eeca5ac..1d010b4 100644 (file)
@@ -16,7 +16,6 @@ import Oracles.Setting
 import Settings
 import Settings.Path
 import Target
-import UserSettings
 import Utilities
 
 libraryObjects :: Context -> Action [FilePath]
@@ -28,7 +27,7 @@ libraryObjects context@Context{..} = do
     -- explicitly as this would needlessly bloat the Shake database).
     need $ noHsObjs ++ hsObjs
 
-    split <- interpretInContext context $ splitObjects flavour
+    split <- interpretInContext context =<< splitObjects <$> flavour
     let getSplitObjs = concatForM hsObjs $ \obj -> do
             let dir = dropExtension obj ++ "_" ++ osuf way ++ "_split"
             contents <- liftIO $ IO.getDirectoryContents dir
index 16c415f..6ca514f 100644 (file)
@@ -13,17 +13,18 @@ import Rules.Wrappers
 import Settings
 import Settings.Path
 import Target
-import UserSettings
 import Utilities
 
+-- TODO: Drop way in build rule generation?
 buildProgram :: [(Resource, Int)] -> Context -> Rules ()
 buildProgram rs context@Context {..} = when (isProgram package) $ do
     let installStage = do
             latest <- latestBuildStage package -- fromJust below is safe
             return $ if package == ghc then stage else fromJust latest
 
-    buildPath context -/- programName context <.> exe %>
-        buildBinaryAndWrapper rs context
+    buildPath context -/- programName context <.> exe %> \bin -> do
+        context' <- programContext stage package
+        buildBinaryAndWrapper rs context' bin
 
     when (package == ghc) $ want inplaceLibCopyTargets
 
@@ -31,22 +32,25 @@ buildProgram rs context@Context {..} = when (isProgram package) $ do
     when (stage == Stage0 || package == ghc) $ do
         -- Some binaries in inplace/bin are wrapped
         inplaceBinPath -/- programName context <.> exe %> \bin -> do
+            context' <- programContext stage package
             binStage <- installStage
-            buildBinaryAndWrapper rs (context { stage = binStage }) bin
+            buildBinaryAndWrapper rs (context' { stage = binStage }) bin
 
         inplaceLibBinPath -/- programName context <.> exe %> \bin -> do
             binStage <- installStage
+            context' <- programContext stage package
             if package /= iservBin then
                 -- We *normally* build only unwrapped binaries in inplace/lib/bin,
-                buildBinary rs (context { stage = binStage }) bin
+                buildBinary rs (context' { stage = binStage }) bin
             else
                 -- build both binary and wrapper in inplace/lib/bin
                 -- for ghc-iserv on *nix platform now
-                buildBinaryAndWrapperLib rs (context { stage = binStage }) bin
+                buildBinaryAndWrapperLib rs (context' { stage = binStage }) bin
 
         inplaceLibBinPath -/- programName context <.> "bin" %> \bin -> do
             binStage <- installStage
-            buildBinary rs (context { stage = binStage }) bin
+            context' <- programContext stage package
+            buildBinary rs (context' { stage = binStage }) bin
 
 buildBinaryAndWrapperLib :: [(Resource, Int)] -> Context -> FilePath -> Action ()
 buildBinaryAndWrapperLib rs context bin = do
index 71a29da..88518f2 100644 (file)
@@ -5,7 +5,6 @@ import Context
 import GHC
 import Settings.Path
 import Target
-import UserSettings
 import Utilities
 
 -- | Build rules for registering packages and initialising package databases
index 3942753..692c8e9 100644 (file)
@@ -10,7 +10,6 @@ import Oracles.Setting
 import Settings
 import Settings.Builders.Ar
 import Target
-import UserSettings
 
 instance Arbitrary Way where
     arbitrary = wayFromUnits <$> arbitrary
index 4db67db..f259442 100644 (file)
@@ -5,7 +5,6 @@ import Hadrian.Oracles.DirectoryContents
 import Base
 import Oracles.Setting
 import Rules.Clean
-import UserSettings
 import Utilities
 
 sourceDistRules :: Rules ()
index 13895a5..c1b5c6c 100644 (file)
@@ -35,6 +35,7 @@ testRules = do
         ghcPkg   <- builderPath $ GhcPkg Update Stage1
         haddock  <- builderPath Haddock
         threads  <- shakeThreads <$> getShakeOptions
+        debugged <- ghcDebugged <$> flavour
         ghcWithNativeCodeGenInt <- fromEnum <$> ghcWithNativeCodeGen
         ghcWithInterpreterInt   <- fromEnum <$> ghcWithInterpreter
         ghcUnregisterisedInt    <- fromEnum <$> flag GhcUnregisterised
@@ -45,7 +46,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=" ++ show (yesNo $ ghcDebugged flavour)
+            , "-e", "ghc_debugged=" ++ show (yesNo debugged)
             , "-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
index e285175..5523020 100644 (file)
@@ -10,7 +10,7 @@ import Hadrian.Oracles.KeyValue
 import Hadrian.Oracles.Path
 
 import Context
-import CmdLineFlag
+import CommandLine
 import Expression
 import Flavour
 import GHC
@@ -26,16 +26,16 @@ import Settings.Path
 import UserSettings
 
 getArgs :: Args
-getArgs = args flavour
+getArgs = expr flavour >>= args
 
 getLibraryWays :: Ways
-getLibraryWays = libraryWays flavour
+getLibraryWays = expr flavour >>= libraryWays
 
 getRtsWays :: Ways
-getRtsWays = rtsWays flavour
+getRtsWays = expr flavour >>= rtsWays
 
 getPackages :: Packages
-getPackages = packages flavour
+getPackages = expr flavour >>= packages
 
 stagePackages :: Stage -> Action [Package]
 stagePackages stage = interpretInContext (stageContext stage) getPackages
@@ -54,20 +54,22 @@ hadrianFlavours =
     [ defaultFlavour, developmentFlavour Stage1, developmentFlavour Stage2
     , performanceFlavour, profiledFlavour, quickFlavour, quickestFlavour ]
 
-flavour :: Flavour
-flavour = fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
-  where
-    unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
-    flavours       = hadrianFlavours ++ userFlavours
-    flavourName    = fromMaybe "default" cmdFlavour
-
-integerLibraryName :: String
-integerLibraryName = pkgNameString $ integerLibrary flavour
-
-programContext :: Stage -> Package -> Context
-programContext stage pkg
-    | pkg == ghc && ghcProfiled flavour && stage > Stage0 = Context stage pkg profiling
-    | otherwise = vanillaContext stage pkg
+flavour :: Action Flavour
+flavour = do
+    flavourName <- fromMaybe "default" <$> cmdFlavour
+    let unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
+        flavours       = hadrianFlavours ++ userFlavours
+    return $ fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
+
+integerLibraryName :: Action String
+integerLibraryName = pkgNameString <$> (integerLibrary =<< flavour)
+
+programContext :: Stage -> Package -> Action Context
+programContext stage pkg = do
+    profiled <- ghcProfiled <$> flavour
+    return $ if pkg == ghc && profiled && stage > Stage0
+             then Context stage pkg profiling
+             else vanillaContext stage pkg
 
 -- 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.
index ee03cbe..d939c6f 100644 (file)
@@ -47,7 +47,8 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
     pkg     <- getPackage
     libs    <- getPkgDataList DepExtraLibs
     libDirs <- getPkgDataList DepLibDirs
-    gmpLibs <- if stage > Stage0 && integerLibrary flavour == integerGmp
+    intLib  <- expr (integerLibrary =<< flavour)
+    gmpLibs <- if stage > Stage0 && intLib == integerGmp
                then do -- TODO: get this data more gracefully
                    let strip = fromMaybe "" . stripPrefix "extra-libraries: "
                    buildInfo <- expr $ readFileLines gmpBuildInfoPath
@@ -62,7 +63,7 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
             , pure [ "-optl-L" ++ unifyPath dir | dir <- libDirs ] ]
 
 splitObjectsArgs :: Args
-splitObjectsArgs = splitObjects flavour ? do
+splitObjectsArgs = splitObjects <$> flavour ? do
     expr $ need [ghcSplitPath]
     arg "-split-objs"
 
index 17ee22c..9d6ab17 100644 (file)
@@ -43,12 +43,13 @@ ghcCabalHsColourBuilderArgs = builder GhcCabalHsColour ? do
 -- TODO: Need compiler_stage1_CONFIGURE_OPTS += --disable-library-for-ghci?
 libraryArgs :: Args
 libraryArgs = do
-    ways     <- getLibraryWays
-    withGhci <- expr ghcWithInterpreter
+    ways        <- getLibraryWays
+    withGhci    <- expr ghcWithInterpreter
+    dynPrograms <- dynamicGhcPrograms <$> expr flavour
     pure [ if vanilla `elem` ways
            then  "--enable-library-vanilla"
            else "--disable-library-vanilla"
-         , if vanilla `elem` ways && withGhci && not (dynamicGhcPrograms flavour)
+         , if vanilla `elem` ways && withGhci && not dynPrograms
            then  "--enable-library-for-ghci"
            else "--disable-library-for-ghci"
          , if profiling `elem` ways
index 810c02d..707bc6f 100644 (file)
@@ -4,7 +4,7 @@ module Settings.Default (
     defaultFlavour, defaultSplitObjects
     ) where
 
-import CmdLineFlag
+import CommandLine
 import Expression
 import Flavour
 import GHC
@@ -124,8 +124,9 @@ stage0Packages = do
 
 stage1Packages :: Packages
 stage1Packages = do
-    win <- expr windowsHost
-    doc <- buildHaddock flavour
+    win    <- expr windowsHost
+    doc    <- buildHaddock =<< expr flavour
+    intLib <- expr (integerLibrary =<< flavour)
     mconcat [ (filter isLibrary) <$> stage0Packages -- Build all Stage0 libraries in Stage1
             , pure $ [ array
                      , base
@@ -141,7 +142,7 @@ stage1Packages = do
                      , haskeline
                      , hpcBin
                      , hsc2hs
-                     , integerLibrary flavour
+                     , intLib
                      , pretty
                      , process
                      , rts
@@ -153,7 +154,7 @@ stage1Packages = do
                      [ xhtml    | doc     ] ]
 
 stage2Packages :: Packages
-stage2Packages = buildHaddock flavour ? pure [ haddock ]
+stage2Packages = buildHaddock <$> flavour ? pure [ haddock ]
 
 -- | Default build ways for library packages:
 -- * We always build 'vanilla' way.
@@ -183,11 +184,11 @@ defaultFlavour = Flavour
     { name               = "default"
     , args               = defaultArgs
     , packages           = defaultPackages
-    , integerLibrary     = if cmdIntegerSimple then integerSimple else integerGmp
+    , integerLibrary     = (\x -> if x then integerSimple else integerGmp) <$> cmdIntegerSimple
     , libraryWays        = defaultLibraryWays
     , rtsWays            = defaultRtsWays
     , splitObjects       = defaultSplitObjects
-    , buildHaddock       = return cmdBuildHaddock
+    , buildHaddock       = expr cmdBuildHaddock
     , dynamicGhcPrograms = False
     , ghciWithDebugger   = False
     , ghcProfiled        = False
@@ -199,8 +200,9 @@ defaultSplitObjects = do
     goodStage <- notStage0 -- We don't split bootstrap (stage 0) packages
     pkg       <- getPackage
     supported <- expr supportsSplitObjects
+    split     <- expr cmdSplitObjects
     let goodPackage = isLibrary pkg && pkg /= compiler && pkg /= rts
-    return $ cmdSplitObjects && goodStage && goodPackage && supported
+    return $ split && goodStage && goodPackage && supported
 
 -- | All 'Builder'-dependent command line arguments.
 defaultBuilderArgs :: Args
index 12b117c..103992b 100644 (file)
@@ -5,6 +5,8 @@ import GHC
 import Settings
 
 basePackageArgs :: Args
-basePackageArgs = package base ? mconcat
-    [ builder GhcCabal ? arg ("--flags=" ++ integerLibraryName)
-    , builder (Ghc CompileCWithGhc) ? arg "-optc-O2" ] -- Fix the 'unknown symbol stat' issue, see #259.
+basePackageArgs = package base ? do
+    integerLibrary <- expr integerLibraryName
+    mconcat [ builder GhcCabal ? arg ("--flags=" ++ integerLibrary)
+            -- Fix the 'unknown symbol stat' issue, see #259.
+            , builder (Ghc CompileCWithGhc) ? arg "-optc-O2" ]
index fefc2f1..4e84ee7 100644 (file)
@@ -37,9 +37,9 @@ compilerPackageArgs = package compiler ? do
                 notM (flag GhcUnregisterised) ?
                 notStage0 ? arg "--ghc-option=-DGHCI_TABLES_NEXT_TO_CODE"
               , ghcWithInterpreter ?
-                ghciWithDebugger flavour ?
+                ghciWithDebugger <$> flavour ?
                 notStage0 ? arg "--ghc-option=-DDEBUGGER"
-              , ghcProfiled flavour ?
+              , ghcProfiled <$> flavour ?
                 notStage0 ? arg "--ghc-pkg-option=--force" ]
 
             , builder Haddock ? arg ("--optghc=-I" ++ path) ]
index 0c9c68a..eb59c20 100644 (file)
@@ -4,14 +4,12 @@
 -- accidentally commit them.
 module UserSettings (
     buildRootPath, userFlavours, userKnownPackages, verboseCommands,
-    putBuild, putSuccess, defaultDestDir, defaultStage1Only
+    buildProgressColour, successColour, defaultDestDir, defaultStage1Only
     ) where
 
-import Development.Shake
 import Hadrian.Utilities
 import System.Console.ANSI
 
-import CmdLineFlag
 import Flavour
 import Expression
 
@@ -31,19 +29,19 @@ userFlavours = []
 userKnownPackages :: [Package]
 userKnownPackages = []
 
--- | Set to True to print full command lines during the build process. Note,
--- this is a Predicate, hence you can enable verbose output only for certain
+-- | Set to 'True' to print full command lines during the build process. Note:
+-- this is a 'Predicate', hence you can enable verbose output only for certain
 -- targets, e.g.: @verboseCommands = package ghcPrim@.
 verboseCommands :: Predicate
 verboseCommands = return False
 
--- | Customise build progress messages (e.g. executing a build command).
-putBuild :: String -> Action ()
-putBuild = putColoured cmdProgressColour Dull Magenta
+-- | Set colour for build progress messages (e.g. executing a build command).
+buildProgressColour :: BuildProgressColour
+buildProgressColour = BuildProgressColour (Dull, Magenta)
 
--- | Customise build success messages (e.g. a package is built successfully).
-putSuccess :: String -> Action ()
-putSuccess = putColoured cmdProgressColour Dull Green
+-- | Set colour for success messages (e.g. a package is built successfully).
+successColour :: SuccessColour
+successColour = SuccessColour (Dull, Green)
 
 -- | Path to the GHC install destination. It is empty by default, which
 -- corresponds to the root of the file system. You can replace it by a specific
index 07b34be..c8b87af 100644 (file)
@@ -16,8 +16,9 @@ import Hadrian.Oracles.ArgsHash
 import Hadrian.Oracles.DirectoryContents
 import Hadrian.Oracles.KeyValue
 import Hadrian.Oracles.Path
+import Hadrian.Utilities
 
-import CmdLineFlag
+import CommandLine
 import Context
 import Expression hiding (builder, inputs, outputs, way, stage, package)
 import GHC
@@ -65,14 +66,16 @@ customBuild rs opts target = do
                 else do
                     input <- interpret target getInput
                     top   <- topDirectory
-                    cmd cmdEcho [Cwd output] [path] "x" (top -/- input)
+                    echo  <- cmdEcho
+                    cmd echo [Cwd output] [path] "x" (top -/- input)
 
             Configure dir -> do
                 -- Inject /bin/bash into `libtool`, instead of /bin/sh, otherwise Windows breaks.
                 -- TODO: Figure out why.
                 bash <- bashPath
+                echo <- cmdEcho
                 let env = AddEnv "CONFIG_SHELL" bash
-                cmd Shell cmdEcho env [Cwd dir] [path] opts argList
+                cmd Shell echo env [Cwd dir] [path] opts argList
 
             HsCpp    -> captureStdout target path argList
             GenApply -> captureStdout target path argList
@@ -84,13 +87,19 @@ customBuild rs opts target = do
                 Stdout output <- cmd (Stdin input) [path] argList
                 writeFileChanged file output
 
-            Make dir -> cmd Shell cmdEcho path ["-C", dir] argList
+            Make dir -> do
+                echo <- cmdEcho
+                cmd Shell echo path ["-C", dir] argList
 
-            _  -> cmd cmdEcho [path] argList
+            _  -> do
+                echo <- cmdEcho
+                cmd echo [path] argList
 
 -- | Suppress build output depending on the @--progress-info@ flag.
-cmdEcho :: CmdOption
-cmdEcho = EchoStdout $ cmdProgressInfo `elem` [Normal, Unicorn]
+cmdEcho :: Action CmdOption
+cmdEcho = do
+    progressInfo <- cmdProgressInfo
+    return $ EchoStdout (progressInfo `elem` [Normal, Unicorn])
 
 -- | Run a builder, capture the standard output, and write it to a given file.
 captureStdout :: Target -> FilePath -> [String] -> Action ()
@@ -105,7 +114,7 @@ copyFile source target = do
     need [source] -- Guarantee source is built before printing progress info.
     let dir = takeDirectory target
     liftIO $ IO.createDirectoryIfMissing True dir
-    putProgressInfo $ renderAction "Copy file" source target
+    putProgressInfo =<< renderAction "Copy file" source target
     copyFileChanged source target
 
 -- | Copy a file without tracking the source, create the target directory if missing.
@@ -113,13 +122,13 @@ copyFileUntracked :: FilePath -> FilePath -> Action ()
 copyFileUntracked source target = do
     let dir = takeDirectory target
     liftIO $ IO.createDirectoryIfMissing True dir
-    putProgressInfo $ renderAction "Copy file (Untracked)" source target
+    putProgressInfo =<< renderAction "Copy file (Untracked)" source target
     liftIO $ IO.copyFile source target
 
 -- | Move a file; we cannot track the source, because it is moved.
 moveFile :: FilePath -> FilePath -> Action ()
 moveFile source target = do
-    putProgressInfo $ renderAction "Move file" source target
+    putProgressInfo =<< renderAction "Move file" source target
     quietly $ cmd ["mv", source, target]
 
 -- | Remove a file that doesn't necessarily exist.
@@ -143,21 +152,21 @@ removeDirectory dir = do
 -- | Copy a directory. The contents of the source directory is untracked.
 copyDirectory :: FilePath -> FilePath -> Action ()
 copyDirectory source target = do
-    putProgressInfo $ renderAction "Copy directory" source target
+    putProgressInfo =<< renderAction "Copy directory" source target
     quietly $ cmd ["cp", "-r", source, target]
 
 -- | Copy the contents of the source directory that matches a given 'Match'
 -- expression into the target directory. The copied contents is tracked.
 copyDirectoryContents :: Match -> FilePath -> FilePath -> Action ()
 copyDirectoryContents expr source target = do
-    putProgressInfo $ renderAction "Copy directory contents" source target
+    putProgressInfo =<< renderAction "Copy directory contents" source target
     let cp file = copyFile file $ target -/- makeRelative source file
     mapM_ cp =<< directoryContents expr source
 
 -- | Move a directory. The contents of the source directory is untracked.
 moveDirectory :: FilePath -> FilePath -> Action ()
 moveDirectory source target = do
-    putProgressInfo $ renderAction "Move directory" source target
+    putProgressInfo =<< renderAction "Move directory" source target
     quietly $ cmd ["mv", source, target]
 
 -- | Transform a given file by applying a function to its contents.
@@ -220,7 +229,7 @@ linkSymbolic source target = do
         need [source] -- Guarantee source is built before printing progress info.
         let dir = takeDirectory target
         liftIO $ IO.createDirectoryIfMissing True dir
-        putProgressInfo $ renderAction "Create symbolic link" source target
+        putProgressInfo =<< renderAction "Create symbolic link" source target
         quietly $ cmd lns source target
 
 isInternal :: Builder -> Bool
@@ -313,7 +322,7 @@ topsortPackages pkgs = do
 
 -- | Print out information about the command being executed.
 putInfo :: Target -> Action ()
-putInfo t = putProgressInfo $ renderAction
+putInfo t = putProgressInfo =<< renderAction
     ("Run " ++ show (builder t) ++ contextInfo)
     (digest $ inputs  t)
     (digest $ outputs t)
@@ -327,95 +336,3 @@ putInfo t = putProgressInfo $ renderAction
     digest [x] = x
     digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
 
--- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
-putProgressInfo :: String -> Action ()
-putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
-
--- | Render an action.
-renderAction :: String -> FilePath -> FilePath -> String
-renderAction what input output = case cmdProgressInfo of
-    Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
-    Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
-    Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
-    None    -> ""
-  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 built 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 next to our favorit 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)
-
--- | Render the given set of lines in a nice box of ASCII.
---
--- 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