[commit: ghc] wip/nfs-locking: Move putColoured to the library (a395dd7)

[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/a395dd71438e58c29448f5f34cf4bb17e9fcbe5d/ghc

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

commit a395dd71438e58c29448f5f34cf4bb17e9fcbe5d
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Sun Aug 13 00:49:18 2017 +0100

    Move putColoured to the library
    
    See #347


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

a395dd71438e58c29448f5f34cf4bb17e9fcbe5d
 src/Base.hs              | 27 +--------------------------
 src/CmdLineFlag.hs       | 16 ++++++++--------
 src/Hadrian/Utilities.hs | 23 ++++++++++++++++++++++-
 src/UserSettings.hs      |  6 ++++--
 4 files changed, 35 insertions(+), 37 deletions(-)

diff --git a/src/Base.hs b/src/Base.hs
index df14d3d..f4f4c4b 100644
--- a/src/Base.hs
+++ b/src/Base.hs
@@ -17,7 +17,7 @@ module Base (
     configPath, configFile, sourcePath,
 
     -- * Miscellaneous utilities
-    unifyPath, quote, (-/-), putColoured
+    unifyPath, quote, (-/-)
     ) where
 
 import Control.Applicative
@@ -32,11 +32,6 @@ import Development.Shake hiding (parallel, unit, (*>), Normal)
 import Development.Shake.Classes
 import Development.Shake.FilePath
 import Hadrian.Utilities
-import System.Console.ANSI
-import System.IO
-import System.Info
-
-import CmdLineFlag
 
 -- TODO: reexport Stage, etc.?
 
@@ -55,23 +50,3 @@ configFile = configPath -/- "system.config"
 -- sourcePath -/- "Base.hs". We use this to `need` some of the source files.
 sourcePath :: FilePath
 sourcePath = hadrianPath -/- "src"
-
--- | A more colourful version of Shake's 'putNormal'.
-putColoured :: ColorIntensity -> Color -> String -> Action ()
-putColoured intensity colour msg = do
-    c <- useColour
-    when c . liftIO $ setSGR [SetColor Foreground intensity colour]
-    putNormal msg
-    when c . liftIO $ do
-        setSGR []
-        hFlush stdout
-
-useColour :: Action Bool
-useColour = case cmdProgressColour of
-    Never  -> return False
-    Always -> return True
-    Auto   -> do
-        supported <- liftIO $ hSupportsANSI stdout
-        -- An ugly hack to always try to print colours when on mingw and cygwin.
-        let windows = any (`isPrefixOf` os) ["mingw", "cygwin"]
-        return $ windows || supported
diff --git a/src/CmdLineFlag.hs b/src/CmdLineFlag.hs
index 961a033..ff35f1f 100644
--- a/src/CmdLineFlag.hs
+++ b/src/CmdLineFlag.hs
@@ -1,11 +1,12 @@
 module CmdLineFlag (
     putCmdLineFlags, cmdFlags, cmdBuildHaddock, cmdFlavour, cmdIntegerSimple,
-    cmdProgressColour, ProgressColour (..), cmdProgressInfo, ProgressInfo (..),
-    cmdSkipConfigure, cmdSplitObjects
+    cmdProgressColour, cmdProgressInfo, ProgressInfo (..), cmdSkipConfigure,
+    cmdSplitObjects
     ) where
 
 import Data.IORef
 import Data.List.Extra
+import Hadrian.Utilities
 import System.Console.GetOpt
 import System.IO.Unsafe
 
@@ -16,14 +17,13 @@ data Untracked = Untracked
     { buildHaddock   :: Bool
     , flavour        :: Maybe String
     , integerSimple  :: Bool
-    , progressColour :: ProgressColour
+    , progressColour :: UseColour
     , progressInfo   :: ProgressInfo
     , skipConfigure  :: Bool
     , splitObjects   :: Bool }
     deriving (Eq, Show)
 
-data ProgressColour = Never | Auto | Always deriving (Eq, Show)
-data ProgressInfo   = None | Brief | Normal | Unicorn deriving (Eq, Show)
+data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show)
 
 -- | Default values for 'CmdLineFlag.Untracked'.
 defaultUntracked :: Untracked
@@ -49,12 +49,12 @@ readProgressColour :: Maybe String -> Either String (Untracked -> Untracked)
 readProgressColour ms =
     maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
   where
-    go :: String -> Maybe ProgressColour
+    go :: String -> Maybe UseColour
     go "never"   = Just Never
     go "auto"    = Just Auto
     go "always"  = Just Always
     go _         = Nothing
-    set :: ProgressColour -> Untracked -> Untracked
+    set :: UseColour -> Untracked -> Untracked
     set flag flags = flags { progressColour = flag }
 
 readProgressInfo :: Maybe String -> Either String (Untracked -> Untracked)
@@ -115,7 +115,7 @@ cmdFlavour = flavour getCmdLineFlags
 cmdIntegerSimple :: Bool
 cmdIntegerSimple = integerSimple getCmdLineFlags
 
-cmdProgressColour :: ProgressColour
+cmdProgressColour :: UseColour
 cmdProgressColour = progressColour getCmdLineFlags
 
 cmdProgressInfo :: ProgressInfo
diff --git a/src/Hadrian/Utilities.hs b/src/Hadrian/Utilities.hs
index f26a444..bf9a9ac 100644
--- a/src/Hadrian/Utilities.hs
+++ b/src/Hadrian/Utilities.hs
@@ -7,12 +7,20 @@ module Hadrian.Utilities (
     quote, yesNo,
 
     -- * FilePath manipulation
-    unifyPath, (-/-), matchVersionedFilePath
+    unifyPath, (-/-), matchVersionedFilePath,
+
+    -- * Miscellaneous
+    UseColour (..), putColoured
     ) where
 
+import Control.Monad
 import Data.Char
 import Data.List.Extra
+import Development.Shake
 import Development.Shake.FilePath
+import System.Console.ANSI
+import System.Info.Extra
+import System.IO
 
 -- | Extract a value from a singleton list, or terminate with an error message
 -- if the list does not contain exactly one value.
@@ -100,3 +108,16 @@ matchVersionedFilePath prefix suffix filePath =
     case stripPrefix prefix filePath >>= stripSuffix suffix of
         Nothing      -> False
         Just version -> all (\c -> isDigit c || c == '-' || c == '.') version
+
+data UseColour = Never | Auto | Always deriving (Eq, Show)
+
+-- | A more colourful version of Shake's 'putNormal'.
+putColoured :: UseColour -> ColorIntensity -> Color -> String -> Action ()
+putColoured useColour intensity colour msg = do
+    supported <- liftIO $ hSupportsANSI stdout
+    let c Never  = False
+        c Auto   = supported || isWindows -- Colours do work on Windows
+        c Always = True
+    when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour]
+    putNormal msg
+    when (c useColour) . liftIO $ setSGR [] >> hFlush stdout
diff --git a/src/UserSettings.hs b/src/UserSettings.hs
index e2aa674..debd7cd 100644
--- a/src/UserSettings.hs
+++ b/src/UserSettings.hs
@@ -7,9 +7,11 @@ module UserSettings (
     putBuild, putSuccess, defaultDestDir, defaultStage1Only
     ) where
 
+import Hadrian.Utilities
 import System.Console.ANSI
 
 import Base
+import CmdLineFlag
 import Flavour
 import Expression
 
@@ -37,11 +39,11 @@ verboseCommands = return False
 
 -- | Customise build progress messages (e.g. executing a build command).
 putBuild :: String -> Action ()
-putBuild = putColoured Dull Magenta
+putBuild = putColoured cmdProgressColour Dull Magenta
 
 -- | Customise build success messages (e.g. a package is built successfully).
 putSuccess :: String -> Action ()
-putSuccess = putColoured Dull Green
+putSuccess = putColoured cmdProgressColour 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