Skip to content
GitLab
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
a5a2fed8
Commit
a5a2fed8
authored
Jan 17, 2015
by
Andrey Mokhov
Browse files
Clean up colourisation code.
parent
2990db6f
Changes
4
Hide whitespace changes
Inline
Side-by-side
src/Config.hs
View file @
a5a2fed8
...
...
@@ -11,15 +11,13 @@ cfgPath = "shake" </> "cfg"
autoconfRules
::
Rules
()
autoconfRules
=
do
"configure"
%>
\
out
->
do
need
[
"shake/src/Config.hs"
]
copyFile'
(
cfgPath
</>
"configure.ac"
)
"configure.ac"
putColoured
Vivid
White
$
"Running autoconf..."
putColoured
White
$
"Running autoconf..."
cmd
"bash autoconf"
-- TODO: get rid of 'bash'
configureRules
::
Rules
()
configureRules
=
do
cfgPath
</>
"default.config"
%>
\
out
->
do
need
[
"shake/src/Config.hs"
]
need
[
cfgPath
</>
"default.config.in"
,
"configure"
]
putColoured
Vivid
White
"Running configure..."
putColoured
White
"Running configure..."
cmd
"bash configure"
-- TODO: get rid of 'bash'
src/Oracles/Builder.hs
View file @
a5a2fed8
...
...
@@ -47,8 +47,8 @@ instance ShowArg Builder where
GhcPkg
Stage0
->
"system-ghc-pkg"
GhcPkg
_
->
"ghc-pkg"
cfgPath
<-
askConfigWithDefault
key
$
e
rror
$
"
\n
Cannot find path to '"
++
key
++
"' in configuration files."
redE
rror
$
"
\n
Cannot find path to '"
++
key
++
"' in configuration files."
let
cfgPathExe
=
if
null
cfgPath
then
""
else
cfgPath
-<.>
exe
windows
<-
windowsHost
-- Note, below is different from FilePath.isAbsolute:
...
...
@@ -104,20 +104,24 @@ run builder as = do
-- Run the builder with a given collection of arguments printing out a
-- terse commentary with only 'interesting' info for the builder.
-- Raises an error if the builder is not uniquely specified in config files
-- TODO: make this a default 'run', rename current 'run' to verboseRun
terseRun
::
ShowArgs
a
=>
Builder
->
a
->
Action
()
terseRun
builder
as
=
do
args
<-
showArgs
as
putColoured
Vivid
White
$
"/--------
\n
"
++
putColoured
White
$
"/--------
\n
"
++
"| Running "
++
show
builder
++
" with arguments:"
mapM_
(
putColoured
Vivid
White
.
(
"| "
++
))
$
mapM_
(
putColoured
White
.
(
"| "
++
))
$
interestingInfo
builder
args
putColoured
Vivid
White
$
"
\\
--------"
putColoured
White
$
"
\\
--------"
quietly
$
run
builder
as
interestingInfo
::
Builder
->
[
String
]
->
[
String
]
interestingInfo
builder
ss
=
case
builder
of
Ar
->
prefixAndSuffix
2
1
ss
Ld
->
prefixAndSuffix
4
0
ss
Gcc
->
if
head
ss
==
"-MM"
then
prefixAndSuffix
1
1
ss
else
ss
Ghc
_
->
if
head
ss
==
"-M"
then
prefixAndSuffix
1
1
ss
else
prefixAndSuffix
0
4
ss
...
...
src/Oracles/Flag.hs
View file @
a5a2fed8
...
...
@@ -41,7 +41,7 @@ test flag = do
GhcUnregisterised
->
(
"ghc-unregisterised"
,
False
)
let
defaultString
=
if
defaultValue
then
"YES"
else
"NO"
value
<-
askConfigWithDefault
key
$
-- TODO: warn just once
do
putColoured
Dull
Red
$
"
\n
Flag '"
do
putColoured
Red
$
"
\n
Flag '"
++
key
++
"' not set in configuration files. "
++
"Proceeding with default value '"
...
...
src/Util.hs
View file @
a5a2fed8
...
...
@@ -3,13 +3,14 @@ module Util (
module
System
.
Console
.
ANSI
,
replaceIf
,
replaceEq
,
replaceSeparators
,
chunksOfSize
,
putColoured
,
redError
putColoured
,
redError
,
redError_
)
where
import
Base
import
Data.Char
import
System.Console.ANSI
import
System.IO
import
Control.Monad
replaceIf
::
(
a
->
Bool
)
->
a
->
[
a
]
->
[
a
]
replaceIf
p
to
=
map
(
\
from
->
if
p
from
then
to
else
from
)
...
...
@@ -36,9 +37,9 @@ chunksOfSize size ss = reverse chunk : chunksOfSize size rest
else
(
newChunk
,
rest
)
-- A more colourful version of Shake's putNormal
putColoured
::
ColorIntensity
->
Color
->
String
->
Action
()
putColoured
intensity
colour
msg
=
do
liftIO
$
setSGR
[
SetColor
Foreground
intensity
colour
]
putColoured
::
Color
->
String
->
Action
()
putColoured
colour
msg
=
do
liftIO
$
setSGR
[
SetColor
Foreground
Vivid
colour
]
putNormal
msg
liftIO
$
setSGR
[]
liftIO
$
hFlush
stdout
...
...
@@ -46,5 +47,8 @@ putColoured intensity colour msg = do
-- A more colourful version of error
redError
::
String
->
Action
a
redError
msg
=
do
putColoured
Vivid
Red
msg
return
$
error
$
"GHC build system error: "
++
msg
putColoured
Red
msg
error
$
"GHC build system error: "
++
msg
redError_
::
String
->
Action
()
redError_
=
void
.
redError
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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