[commit: ghc] wip/nfs-locking: Clean up colourisation code. (a5a2fed)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/a5a2fed84493a7afa0942ba28a33b1ae9bc2a804/ghc

>---------------------------------------------------------------

commit a5a2fed84493a7afa0942ba28a33b1ae9bc2a804
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Sat Jan 17 23:12:02 2015 +0000

    Clean up colourisation code.


>---------------------------------------------------------------

a5a2fed84493a7afa0942ba28a33b1ae9bc2a804
 src/Config.hs          |  6 ++----
 src/Oracles/Builder.hs | 14 +++++++++-----
 src/Oracles/Flag.hs    |  2 +-
 src/Util.hs            | 16 ++++++++++------
 4 files changed, 22 insertions(+), 16 deletions(-)

diff --git a/src/Config.hs b/src/Config.hs
index dd5db2a..1a4ef9a 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -11,15 +11,13 @@ cfgPath = "shake" </> "cfg"
 autoconfRules :: Rules ()
 autoconfRules = do
     "configure" %> \out -> do
-        need ["shake/src/Config.hs"]
         copyFile' (cfgPath </> "configure.ac") "configure.ac"
-        putColoured Vivid White $ "Running autoconf..."
+        putColoured White $ "Running autoconf..."
         cmd "bash autoconf" -- TODO: get rid of 'bash'
 
 configureRules :: Rules ()
 configureRules = do
     cfgPath </> "default.config" %> \out -> do
-        need ["shake/src/Config.hs"]
         need [cfgPath </> "default.config.in", "configure"]
-        putColoured Vivid White "Running configure..."
+        putColoured White "Running configure..."
         cmd "bash configure" -- TODO: get rid of 'bash'
diff --git a/src/Oracles/Builder.hs b/src/Oracles/Builder.hs
index 3386b6f..13b8d7c 100644
--- a/src/Oracles/Builder.hs
+++ b/src/Oracles/Builder.hs
@@ -47,8 +47,8 @@ instance ShowArg Builder where
                 GhcPkg Stage0 -> "system-ghc-pkg"
                 GhcPkg _      -> "ghc-pkg"
         cfgPath <- askConfigWithDefault key $
-            error $ "\nCannot find path to '" ++ key
-                  ++ "' in configuration files."
+            redError $ "\nCannot find path to '" ++ key
+                     ++ "' in configuration files."
         let cfgPathExe = if null cfgPath then "" else cfgPath -<.> exe
         windows <- windowsHost
         -- Note, below is different from FilePath.isAbsolute:
@@ -104,20 +104,24 @@ run builder as = do
 -- Run the builder with a given collection of arguments printing out a
 -- terse commentary with only 'interesting' info for the builder.
 -- Raises an error if the builder is not uniquely specified in config files
+-- TODO: make this a default 'run', rename current 'run' to verboseRun
 terseRun :: ShowArgs a => Builder -> a -> Action ()
 terseRun builder as = do
     args <- showArgs as
-    putColoured Vivid White $ "/--------\n" ++
+    putColoured White $ "/--------\n" ++
         "| Running " ++ show builder ++ " with arguments:"
-    mapM_ (putColoured Vivid White . ("|   " ++)) $
+    mapM_ (putColoured White . ("|   " ++)) $
         interestingInfo builder args
-    putColoured Vivid White $ "\\--------"
+    putColoured White $ "\\--------"
     quietly $ run builder as
 
 interestingInfo :: Builder -> [String] -> [String]
 interestingInfo builder ss = case builder of
     Ar       -> prefixAndSuffix 2 1 ss
     Ld       -> prefixAndSuffix 4 0 ss
+    Gcc      -> if head ss == "-MM"
+                then prefixAndSuffix 1 1 ss
+                else ss
     Ghc _    -> if head ss == "-M"
                 then prefixAndSuffix 1 1 ss
                 else prefixAndSuffix 0 4 ss
diff --git a/src/Oracles/Flag.hs b/src/Oracles/Flag.hs
index 6339696..fa29415 100644
--- a/src/Oracles/Flag.hs
+++ b/src/Oracles/Flag.hs
@@ -41,7 +41,7 @@ test flag = do
         GhcUnregisterised  -> ("ghc-unregisterised"   , False)
     let defaultString = if defaultValue then "YES" else "NO"
     value <- askConfigWithDefault key $ -- TODO: warn just once
-        do putColoured Dull Red $ "\nFlag '"
+        do putColoured Red $ "\nFlag '"
                 ++ key
                 ++ "' not set in configuration files. "
                 ++ "Proceeding with default value '"
diff --git a/src/Util.hs b/src/Util.hs
index 5bec54d..16728ce 100644
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -3,13 +3,14 @@ module Util (
     module System.Console.ANSI,
     replaceIf, replaceEq, replaceSeparators,
     chunksOfSize,
-    putColoured, redError
+    putColoured, redError, redError_
     ) where
 
 import Base
 import Data.Char
 import System.Console.ANSI
 import System.IO
+import Control.Monad
 
 replaceIf :: (a -> Bool) -> a -> [a] -> [a]
 replaceIf p to = map (\from -> if p from then to else from)
@@ -36,9 +37,9 @@ chunksOfSize size ss = reverse chunk : chunksOfSize size rest
                                 else (newChunk, rest)
 
 -- A more colourful version of Shake's putNormal
-putColoured :: ColorIntensity -> Color -> String -> Action ()
-putColoured intensity colour msg = do
-    liftIO $ setSGR [SetColor Foreground intensity colour]
+putColoured :: Color -> String -> Action ()
+putColoured colour msg = do
+    liftIO $ setSGR [SetColor Foreground Vivid colour]
     putNormal msg
     liftIO $ setSGR []
     liftIO $ hFlush stdout
@@ -46,5 +47,8 @@ putColoured intensity colour msg = do
 -- A more colourful version of error
 redError :: String -> Action a
 redError msg = do
-    putColoured Vivid Red msg
-    return $ error $ "GHC build system error: " ++ msg
+    putColoured Red msg
+    error $ "GHC build system error: " ++ msg
+
+redError_ :: String -> Action ()
+redError_ = void . redError