Commit fa77d934 authored by Andrey Mokhov's avatar Andrey Mokhov

Make build progress info colours customisable, drop putError and putOracle.

See #244.
parent 34545e3d
......@@ -17,12 +17,9 @@ module Base (
-- * Paths
configPath, configFile, sourcePath, programInplacePath,
-- * Output
putColoured, putOracle, putBuild, putSuccess, putError,
-- * Miscellaneous utilities
minusOrd, intersectOrd, lookupAll, replaceEq, quote, replaceSeparators,
unifyPath, (-/-), versionToInt, matchVersionedFilePath
unifyPath, (-/-), versionToInt, matchVersionedFilePath, putColoured
) where
import Control.Applicative
......@@ -38,8 +35,8 @@ import Development.Shake hiding (parallel, unit, (*>), Normal)
import Development.Shake.Classes
import Development.Shake.FilePath
import System.Console.ANSI
import qualified System.Info as Info
import System.IO
import System.Info
-- TODO: reexport Stage, etc.?
......@@ -62,23 +59,22 @@ sourcePath = hadrianPath -/- "src"
programInplacePath :: FilePath
programInplacePath = "inplace/bin"
-- Utility functions
-- | Find and replace all occurrences of a value in a list
-- | Find and replace all occurrences of a value in a list.
replaceEq :: Eq a => a -> a -> [a] -> [a]
replaceEq from = replaceWhen (== from)
-- | Find and replace all occurrences of path separators in a String with a Char
-- | Find and replace all occurrences of path separators in a String with a Char.
replaceSeparators :: Char -> String -> String
replaceSeparators = replaceWhen isPathSeparator
replaceWhen :: (a -> Bool) -> a -> [a] -> [a]
replaceWhen p to = map (\from -> if p from then to else from)
-- | Add quotes to a String
-- | Add quotes around a String.
quote :: String -> String
quote s = "\"" ++ s ++ "\""
-- | Given a version string such as "2.16.2" produce an integer equivalent
-- | Given a version string such as "2.16.2" produce an integer equivalent.
versionToInt :: String -> Int
versionToInt s = major * 1000 + minor * 10 + patch
where
......@@ -97,39 +93,6 @@ a -/- b
infixr 6 -/-
-- | A more colourful version of Shake's putNormal
putColoured :: Color -> String -> Action ()
putColoured colour msg = do
liftIO $ set [SetColor Foreground Vivid colour]
putNormal msg
liftIO $ set []
liftIO $ hFlush stdout
where
set a = do
supported <- hSupportsANSI stdout
when (win || supported) $ setSGR a
-- An ugly hack to always try to print colours when on mingw and cygwin.
-- See: https://github.com/snowleopard/hadrian/pull/253
win = "mingw" `isPrefixOf` Info.os || "cygwin" `isPrefixOf` Info.os
-- | Make oracle output more distinguishable
putOracle :: String -> Action ()
putOracle = putColoured Blue
-- | Make build output more distinguishable
putBuild :: String -> Action ()
putBuild = putColoured White
-- | A more colourful version of success message
putSuccess :: String -> Action ()
putSuccess = putColoured Green
-- | A more colourful version of error message
putError :: String -> Action a
putError msg = do
putColoured Red msg
error $ "GHC build system error: " ++ msg
-- Explicit definition to avoid dependency on Data.List.Ordered
-- | Difference of two ordered lists.
minusOrd :: Ord a => [a] -> [a] -> [a]
......@@ -182,3 +145,18 @@ matchVersionedFilePath prefix suffix filePath =
case stripPrefix prefix filePath >>= stripSuffix suffix of
Nothing -> False
Just version -> all (\c -> isDigit c || c == '-' || c == '.') version
-- | A more colourful version of Shake's putNormal.
putColoured :: ColorIntensity -> Color -> String -> Action ()
putColoured intensity colour msg = do
liftIO $ set [SetColor Foreground intensity colour]
putNormal msg
liftIO $ set []
liftIO $ hFlush stdout
where
set a = do
supported <- hSupportsANSI stdout
when (win || supported) $ setSGR a
-- An ugly hack to always try to print colours when on mingw and cygwin.
-- See: https://github.com/snowleopard/hadrian/pull/253
win = "mingw" `isPrefixOf` os || "cygwin" `isPrefixOf` os
......@@ -121,13 +121,13 @@ builderPath builder = case builderProvenance builder of
_ -> error $ "Cannot determine builderPath for " ++ show builder
where
fromKey key = do
path <- askConfigWithDefault key . putError $ "\nCannot find path to '"
path <- askConfigWithDefault key . error $ "\nCannot find path to '"
++ key ++ "' in system.config file. Did you forget to run configure?"
if null path
then do
if isOptional builder
then return ""
else putError $ "Builder '" ++ key ++ "' is not specified in"
else error $ "Builder '" ++ key ++ "' is not specified in"
++ " system.config file. Cannot proceed without it."
else fixAbsolutePathOnWindows =<< lookupInPath path
......
......@@ -211,4 +211,4 @@ getSingleton expr msg = do
xs <- expr
case xs of
[res] -> return res
_ -> lift $ putError msg
_ -> error msg
......@@ -10,7 +10,7 @@ newtype ConfigKey = ConfigKey String
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
askConfig :: String -> Action String
askConfig key = askConfigWithDefault key . putError
askConfig key = askConfigWithDefault key . error
$ "Cannot find key '" ++ key ++ "' in configuration files."
askConfigWithDefault :: String -> Action String -> Action String
......@@ -25,7 +25,7 @@ configOracle :: Rules ()
configOracle = do
cfg <- newCache $ \() -> do
need [configFile]
putOracle $ "Reading " ++ configFile ++ "..."
putLoud $ "Reading " ++ configFile ++ "..."
liftIO $ readConfigFile configFile
_ <- addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()
return ()
......@@ -38,9 +38,9 @@ flag f = do
SupportsThisUnitId -> "supports-this-unit-id"
WithLibdw -> "with-libdw"
UseSystemFfi -> "use-system-ffi"
value <- askConfigWithDefault key . putError
value <- askConfigWithDefault key . error
$ "\nFlag '" ++ key ++ "' not set in configuration files."
unless (value == "YES" || value == "NO" || value == "") . putError
unless (value == "YES" || value == "NO" || value == "") . error
$ "\nFlag '" ++ key ++ "' is set to '" ++ value
++ "' instead of 'YES' or 'NO'."
return $ value == "YES"
......
......@@ -23,15 +23,15 @@ dependencies path obj = do
$ map (\obj' -> MaybeT $ askOracle $ DependenciesKey (depFile, obj'))
[obj, obj -<.> "o"]
case res of
Nothing -> putError $ "No dependencies found for '" ++ obj ++ "'."
Just [] -> putError $ "Empty dependency list for '" ++ obj ++ "'."
Nothing -> error $ "No dependencies found for '" ++ obj ++ "'."
Just [] -> error $ "Empty dependency list for '" ++ obj ++ "'."
Just (src:depFiles) -> return (src, depFiles)
-- Oracle for 'path/dist/.dependencies' files
dependenciesOracle :: Rules ()
dependenciesOracle = void $ do
deps <- newCache $ \file -> do
putOracle $ "Reading dependencies from " ++ file ++ "..."
putLoud $ "Reading dependencies from " ++ file ++ "..."
contents <- map words <$> readFileLines file
return . Map.fromList $ map (\(x:xs) -> (x, xs)) contents
addOracle $ \(DependenciesKey (file, obj)) -> Map.lookup obj <$> deps file
......@@ -20,6 +20,6 @@ lookupInPathOracle = void $
maybePath <- liftIO $ findExecutable name
path <- case maybePath of
Just value -> return $ unifyPath value
Nothing -> putError $ "Cannot find executable '" ++ name ++ "'."
putOracle $ "Executable found: " ++ name ++ " => " ++ path
Nothing -> error $ "Cannot find executable '" ++ name ++ "'."
putLoud $ "Executable found: " ++ name ++ " => " ++ path
return path
......@@ -127,7 +127,7 @@ moduleFilesOracle = void $ do
multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
unless (null multi) $ do
let (m, f1, f2) = head multi
putError $ "Module " ++ m ++ " has more than one source file: "
error $ "Module " ++ m ++ " has more than one source file: "
++ f1 ++ " and " ++ f2 ++ "."
return $ lookupAll modules pairs
......
......@@ -86,7 +86,7 @@ packageDataOracle :: Rules ()
packageDataOracle = do
keys <- newCache $ \file -> do
need [file]
putOracle $ "Reading " ++ file ++ "..."
putLoud $ "Reading " ++ file ++ "..."
liftIO $ readConfigFile file
_ <- addOracle $ \(PackageDataKey (file, key)) -> Map.lookup key <$> keys file
return ()
......@@ -3,12 +3,13 @@ module Oracles.PackageDb (packageDbOracle) where
import qualified System.Directory as IO
import Base
import Context hiding (stage)
import Context
import Builder
import GHC
import Rules.Actions
import Settings.Builders.GhcCabal
import Settings.Paths
import Settings.User
import Target
packageDbOracle :: Rules ()
......
......@@ -22,7 +22,7 @@ packageDeps pkg = do
packageDepsOracle :: Rules ()
packageDepsOracle = do
deps <- newCache $ \_ -> do
putOracle $ "Reading package dependencies..."
putLoud $ "Reading package dependencies..."
contents <- readFileLines packageDependencies
return . Map.fromList $
[ (p, ps) | line <- contents, let p:ps = words line ]
......
......@@ -36,5 +36,5 @@ windowsPathOracle = void $
addOracle $ \(WindowsPath path) -> do
Stdout out <- quietly $ cmd ["cygpath", "-m", path]
let windowsPath = unifyPath $ dropWhileEnd isSpace out
putOracle $ "Windows path mapping: " ++ path ++ " => " ++ windowsPath
putLoud $ "Windows path mapping: " ++ path ++ " => " ++ windowsPath
return windowsPath
module Rules.Actions (
build, buildWithCmdOptions, buildWithResources, copyFile, fixFile, moveFile,
removeFile, copyDirectory, createDirectory, moveDirectory, removeDirectory,
applyPatch, renderLibrary, renderProgram, runBuilder, makeExecutable
applyPatch, runBuilder, makeExecutable, renderProgram, renderLibrary
) where
import qualified System.Directory as IO
......
......@@ -9,6 +9,7 @@ import Context
import GHC
import Rules.Actions
import Rules.Generators.GhcAutoconfH
import Settings.User
import Stage
import Target
......@@ -17,7 +18,7 @@ configureRules = do
[configFile, "settings", configH] &%> \outs -> do
if cmdSkipConfigure
then unlessM (doesFileExist configFile) $
putError $ "Configuration file " ++ configFile ++ " is missing."
error $ "Configuration file " ++ configFile ++ " is missing."
++ "\nRun the configure script manually or do not use the "
++ "--skip-configure flag."
else do
......@@ -33,7 +34,7 @@ configureRules = do
["configure", configH <.> "in"] &%> \_ -> do
if cmdSkipConfigure
then unlessM (doesFileExist "configure") $
putError $ "The configure script is missing.\nRun the boot script"
error $ "The configure script is missing.\nRun the boot script"
++ " manually or do not use the --skip-configure flag."
else do
need ["configure.ac"]
......
......@@ -6,7 +6,7 @@ module Rules.Generate (
import qualified System.Directory as IO
import Base
import Context hiding (stage)
import Context
import Expression
import GHC
import Oracles.ModuleFiles
......@@ -20,7 +20,7 @@ import Rules.Generators.GhcVersionH
import Rules.Generators.VersionHs
import Rules.Libffi
import Settings
import Target hiding (builder, context)
import Target
installTargets :: [FilePath]
installTargets = [ "inplace/lib/ghc-usage.txt"
......@@ -109,7 +109,7 @@ generatePackageCode context@(Context stage pkg _) =
generated ?> \file -> do
maybeValue <- findGenerator context file
(src, builder) <- case maybeValue of
Nothing -> putError $ "No generator for " ++ file ++ "."
Nothing -> error $ "No generator for " ++ file ++ "."
Just value -> return value
need [src]
build $ Target context builder [src] [file]
......
......@@ -56,7 +56,7 @@ gmpRules = do
tarballs <- getDirectoryFiles "" [gmpBase -/- "tarball/gmp*.tar.bz2"]
tarball <- case tarballs of
[file] -> return $ unifyPath file
_ -> putError $ "gmpRules: exactly one tarball expected"
_ -> error $ "gmpRules: exactly one tarball expected"
++ "(found: " ++ show tarballs ++ ")."
withTempDir $ \dir -> do
......@@ -73,7 +73,7 @@ gmpRules = do
let name = dropExtension . dropExtension $ takeFileName tarball
libName <- case stripSuffix "-nodoc-patched" name of
Just rest -> return rest
Nothing -> putError $ "gmpRules: expected suffix "
Nothing -> error $ "gmpRules: expected suffix "
++ "-nodoc-patched (found: " ++ name ++ ")."
moveDirectory (tmp -/- libName) gmpBuildPath
......
......@@ -74,7 +74,7 @@ libffiRules = do
tarballs <- getDirectoryFiles "" ["libffi-tarballs/libffi*.tar.gz"]
tarball <- case tarballs of
[file] -> return $ unifyPath file
_ -> putError $ "libffiRules: exactly one tarball expected"
_ -> error $ "libffiRules: exactly one tarball expected"
++ "(found: " ++ show tarballs ++ ")."
need [tarball]
......
......@@ -5,7 +5,7 @@ module Rules.Library (
import Data.Char
import qualified System.Directory as IO
import Base hiding (split, splitPath)
import Base
import Context
import Expression
import GHC
......
......@@ -5,7 +5,7 @@ import Data.Char
import Base
import Context
import Expression
import GHC hiding (ghci)
import GHC
import Oracles.Config.Setting
import Oracles.PackageData
import Rules.Actions
......
......@@ -8,6 +8,7 @@ import Test.QuickCheck
import Base
import Oracles.ModuleFiles
import Settings.Builders.Ar
import Settings.User
import Way
instance Arbitrary Way where
......
......@@ -2,9 +2,11 @@ module Settings.User (
buildRootPath, trackBuildSystem, userArgs, userPackages, userLibraryWays,
userRtsWays, userKnownPackages, integerLibrary, buildHaddock, validating,
ghciWithDebugger, ghcProfiled, ghcDebugged, dynamicGhcPrograms,
verboseCommands, turnWarningsIntoErrors, splitObjects
turnWarningsIntoErrors, splitObjects, verboseCommands, putBuild, putSuccess
) where
import System.Console.ANSI
import Base
import CmdLineFlag
import GHC
......@@ -83,13 +85,21 @@ ghcProfiled = False
ghcDebugged :: Bool
ghcDebugged = False
-- TODO: Replace with stage2 ? arg "-Werror"? Also see #251.
-- | To enable -Werror in Stage2 set turnWarningsIntoErrors = stage2.
turnWarningsIntoErrors :: Predicate
turnWarningsIntoErrors = return False
-- | 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
-- TODO: Replace with stage2 ? arg "-Werror"? Also see #251.
-- | To enable -Werror in Stage2 set turnWarningsIntoErrors = stage2.
turnWarningsIntoErrors :: Predicate
turnWarningsIntoErrors = return False
-- | Customise build progress messages (e.g. executing a build command).
putBuild :: String -> Action ()
putBuild = putColoured Vivid White
-- | Customise build success messages (e.g. a package is built successfully).
putSuccess :: String -> Action ()
putSuccess = putColoured Vivid Green
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