summaryrefslogtreecommitdiff
path: root/compiler/utils/PprColour.hs
blob: f32b8b00847ff4401f71707e439bbf42cbba63da (plain)
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)
        _ -> []