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

Move putColoured to the library

See #347
parent 78878b77
......@@ -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
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
......
......@@ -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
......@@ -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
......
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