Commit a5a2fed8 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Clean up colourisation code.

parent 2990db6f
......@@ -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'
......@@ -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
......
......@@ -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 '"
......
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment