Make build progress info colours customisable, drop putError and putOracle.
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Tue, 17 May 2016 22:36:41 +0000 (23:36 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Tue, 17 May 2016 22:36:41 +0000 (23:36 +0100)
See #244.

21 files changed:
src/Base.hs
src/Builder.hs
src/Expression.hs
src/Oracles/Config.hs
src/Oracles/Config/Flag.hs
src/Oracles/Dependencies.hs
src/Oracles/LookupInPath.hs
src/Oracles/ModuleFiles.hs
src/Oracles/PackageData.hs
src/Oracles/PackageDb.hs
src/Oracles/PackageDeps.hs
src/Oracles/WindowsPath.hs
src/Rules/Actions.hs
src/Rules/Configure.hs
src/Rules/Generate.hs
src/Rules/Gmp.hs
src/Rules/Libffi.hs
src/Rules/Library.hs
src/Rules/Program.hs
src/Rules/Selftest.hs
src/Settings/User.hs

index f2a75e7..328eb98 100644 (file)
@@ -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
index 6f53a12..46c696f 100644 (file)
@@ -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
 
index e4fe416..5f07746 100644 (file)
@@ -211,4 +211,4 @@ getSingleton expr msg = do
     xs <- expr
     case xs of
         [res] -> return res
-        _     -> lift $ putError msg
+        _     -> error msg
index 40b5df3..cb6bcee 100644 (file)
@@ -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 ()
index 449e2b2..de4b5b9 100644 (file)
@@ -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"
index 08b3afa..ef688cb 100644 (file)
@@ -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
index 18c990b..9d65270 100644 (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
index 43a5f00..be9c922 100644 (file)
@@ -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
 
index 6a01692..c04af65 100644 (file)
@@ -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 ()
index 760f2a7..61b134a 100644 (file)
@@ -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 ()
index c70b959..ddfac51 100644 (file)
@@ -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 ]
index 3cbf73b..d67e1b2 100644 (file)
@@ -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
index 4a0844b..d622739 100644 (file)
@@ -1,7 +1,7 @@
 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
index d13417c..94c678b 100644 (file)
@@ -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"]
index 3f408ef..daebe5d 100644 (file)
@@ -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]
index c7bfba7..845ba6e 100644 (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
index 3269a31..6eb9114 100644 (file)
@@ -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]
index a45b591..74a471e 100644 (file)
@@ -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
index 2cee06c..37fc40f 100644 (file)
@@ -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
index 870cdac..977548f 100644 (file)
@@ -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
index f246c06..16c7c25 100644 (file)
@@ -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