1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
module PprColour where
import GhcPrelude
import Data.Maybe (fromMaybe)
import Util (OverridingBool(..), split)
import Data.Semigroup as Semi
-- | A colour\/style for use with 'coloured'.
newtype PprColour = PprColour { renderColour :: String }
instance Semi.Semigroup PprColour where
PprColour s1 <> PprColour s2 = PprColour (s1 <> s2)
-- | Allow colours to be combined (e.g. bold + red);
-- In case of conflict, right side takes precedence.
instance Monoid PprColour where
mempty = PprColour mempty
mappend = (<>)
renderColourAfresh :: PprColour -> String
renderColourAfresh c = renderColour (colReset `mappend` c)
colCustom :: String -> PprColour
colCustom "" = mempty
colCustom s = PprColour ("\27[" ++ s ++ "m")
colReset :: PprColour
colReset = colCustom "0"
colBold :: PprColour
colBold = colCustom ";1"
colBlackFg :: PprColour
colBlackFg = colCustom "30"
colRedFg :: PprColour
colRedFg = colCustom "31"
colGreenFg :: PprColour
colGreenFg = colCustom "32"
colYellowFg :: PprColour
colYellowFg = colCustom "33"
colBlueFg :: PprColour
colBlueFg = colCustom "34"
colMagentaFg :: PprColour
colMagentaFg = colCustom "35"
colCyanFg :: PprColour
colCyanFg = colCustom "36"
colWhiteFg :: PprColour
colWhiteFg = colCustom "37"
data Scheme =
Scheme
{ sHeader :: PprColour
, sMessage :: PprColour
, sWarning :: PprColour
, sError :: PprColour
, sFatal :: PprColour
, sMargin :: PprColour
}
defaultScheme :: Scheme
defaultScheme =
Scheme
{ sHeader = mempty
, sMessage = colBold
, sWarning = colBold `mappend` colMagentaFg
, sError = colBold `mappend` colRedFg
, sFatal = colBold `mappend` colRedFg
, sMargin = colBold `mappend` colBlueFg
}
-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@
-- environment variable).
parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme)
parseScheme "always" (_, cs) = (Always, cs)
parseScheme "auto" (_, cs) = (Auto, cs)
parseScheme "never" (_, cs) = (Never, cs)
parseScheme input (b, cs) =
( b
, Scheme
{ sHeader = fromMaybe (sHeader cs) (lookup "header" table)
, sMessage = fromMaybe (sMessage cs) (lookup "message" table)
, sWarning = fromMaybe (sWarning cs) (lookup "warning" table)
, sError = fromMaybe (sError cs) (lookup "error" table)
, sFatal = fromMaybe (sFatal cs) (lookup "fatal" table)
, sMargin = fromMaybe (sMargin cs) (lookup "margin" table)
}
)
where
table = do
w <- split ':' input
let (k, v') = break (== '=') w
case v' of
'=' : v -> return (k, colCustom v)
_ -> []
|
