Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
a395dd71
Commit
a395dd71
authored
Aug 13, 2017
by
Andrey Mokhov
Browse files
Move putColoured to the library
See
#347
parent
78878b77
Changes
4
Hide whitespace changes
Inline
Side-by-side
src/Base.hs
View file @
a395dd71
...
...
@@ -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
src/CmdLineFlag.hs
View file @
a395dd71
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
::
Progress
Colour
,
progressColour
::
Use
Colour
,
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
Progress
Colour
go
::
String
->
Maybe
Use
Colour
go
"never"
=
Just
Never
go
"auto"
=
Just
Auto
go
"always"
=
Just
Always
go
_
=
Nothing
set
::
Progress
Colour
->
Untracked
->
Untracked
set
::
Use
Colour
->
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
::
Progress
Colour
cmdProgressColour
::
Use
Colour
cmdProgressColour
=
progressColour
getCmdLineFlags
cmdProgressInfo
::
ProgressInfo
...
...
src/Hadrian/Utilities.hs
View file @
a395dd71
...
...
@@ -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
src/UserSettings.hs
View file @
a395dd71
...
...
@@ -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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment