[commit: ghc] wip/nfs-locking: Add --progress-colour command line flag (aa9c65b)

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

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

commit aa9c65b3adb91b56c1974a0db39ef3c5082e816c
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Wed May 18 02:54:23 2016 +0100

    Add --progress-colour command line flag
    
    Fix #244.


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

aa9c65b3adb91b56c1974a0db39ef3c5082e816c
 src/Base.hs        | 27 +++++++++++++++++----------
 src/CmdLineFlag.hs | 51 ++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 53 insertions(+), 25 deletions(-)

diff --git a/src/Base.hs b/src/Base.hs
index 6fe8ac1..cb040d4 100644
--- a/src/Base.hs
+++ b/src/Base.hs
@@ -38,6 +38,8 @@ import System.Console.ANSI
 import System.IO
 import System.Info
 
+import CmdLineFlag
+
 -- TODO: reexport Stage, etc.?
 
 -- | Hadrian lives in 'hadrianPath' directory of the GHC tree.
@@ -144,14 +146,19 @@ matchVersionedFilePath prefix suffix filePath =
 -- | A more colourful version of Shake's putNormal.
 putColoured :: ColorIntensity -> Color -> String -> Action ()
 putColoured intensity colour msg = do
-    liftIO $ set [SetColor Foreground intensity colour]
+    c <- useColour
+    when c . liftIO $ setSGR [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
+    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 8fc1487..10c39f2 100644
--- a/src/CmdLineFlag.hs
+++ b/src/CmdLineFlag.hs
@@ -1,35 +1,39 @@
 module CmdLineFlag (
     putCmdLineFlags, cmdFlags, cmdBuildHaddock, cmdFlavour, Flavour (..),
-    cmdProgressInfo, ProgressInfo (..), cmdSkipConfigure, cmdSplitObjects
+    cmdProgressColour, ProgressColour (..), cmdProgressInfo, ProgressInfo (..),
+    cmdSkipConfigure, cmdSplitObjects
     ) where
 
 import Data.IORef
 import Data.List.Extra
 import System.Console.GetOpt
-import System.IO.Unsafe (unsafePerformIO)
+import System.IO.Unsafe
 
 -- | 'CmdLineFlag.Untracked' is a collection of flags that can be passed via the
 -- command line. These flags are not tracked, that is they do not force any
 -- build rules to be rurun.
 data Untracked = Untracked
-    { buildHaddock  :: Bool
-    , flavour       :: Flavour
-    , progressInfo  :: ProgressInfo
-    , skipConfigure :: Bool
-    , splitObjects  :: Bool }
+    { buildHaddock   :: Bool
+    , flavour        :: Flavour
+    , progressColour :: ProgressColour
+    , progressInfo   :: ProgressInfo
+    , skipConfigure  :: Bool
+    , splitObjects   :: Bool }
     deriving (Eq, Show)
 
-data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show)
-data Flavour      = Default | Quick deriving (Eq, Show)
+data Flavour        = Default | Quick deriving (Eq, Show)
+data ProgressColour = Never | Auto | Always deriving (Eq, Show)
+data ProgressInfo   = None | Brief | Normal | Unicorn deriving (Eq, Show)
 
 -- | Default values for 'CmdLineFlag.Untracked'.
 defaultUntracked :: Untracked
 defaultUntracked = Untracked
-    { buildHaddock  = False
-    , flavour       = Default
-    , progressInfo  = Normal
-    , skipConfigure = False
-    , splitObjects  = False }
+    { buildHaddock   = False
+    , flavour        = Default
+    , progressColour = Auto
+    , progressInfo   = Normal
+    , skipConfigure  = False
+    , splitObjects   = False }
 
 readBuildHaddock :: Either String (Untracked -> Untracked)
 readBuildHaddock = Right $ \flags -> flags { buildHaddock = True }
@@ -45,6 +49,18 @@ readFlavour ms =
     set :: Flavour -> Untracked -> Untracked
     set flag flags = flags { flavour = flag }
 
+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 "never"   = Just Never
+    go "auto"    = Just Auto
+    go "always"  = Just Always
+    go _         = Nothing
+    set :: ProgressColour -> Untracked -> Untracked
+    set flag flags = flags { progressColour = flag }
+
 readProgressInfo :: Maybe String -> Either String (Untracked -> Untracked)
 readProgressInfo ms =
     maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
@@ -70,8 +86,10 @@ cmdFlags =
       "Build flavour (Default or Quick)."
     , Option [] ["haddock"] (NoArg readBuildHaddock)
       "Generate Haddock documentation."
+    , Option [] ["progress-colour"] (OptArg readProgressColour "MODE")
+      "Use colours in progress info (Never, Auto or Always)."
     , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
-      "Progress info style (None, Brief, Normal, or Unicorn)."
+      "Progress info style (None, Brief, Normal or Unicorn)."
     , Option [] ["skip-configure"] (NoArg readSkipConfigure)
       "Skip the boot and configure scripts (if you want to run them manually)."
     , Option [] ["split-objects"] (NoArg readSplitObjects)
@@ -96,6 +114,9 @@ cmdBuildHaddock = buildHaddock getCmdLineFlags
 cmdFlavour :: Flavour
 cmdFlavour = flavour getCmdLineFlags
 
+cmdProgressColour :: ProgressColour
+cmdProgressColour = progressColour getCmdLineFlags
+
 cmdProgressInfo :: ProgressInfo
 cmdProgressInfo = progressInfo getCmdLineFlags