/
Colors.hs
112 lines (97 loc) · 3.73 KB
/
Colors.hs
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
102
103
104
105
106
107
108
109
110
111
112
{-# Language OverloadedStrings, ApplicativeDo, LambdaCase, BlockArguments #-}
{-|
Module : Client.Configuration
Description : Client configuration format and operations
Copyright : (c) Eric Mertens, 2016
License : ISC
Maintainer : emertens@gmail.com
This module defines the top-level configuration information for the client.
-}
module Client.Configuration.Colors
( colorSpec
, attrSpec
) where
import Config.Schema
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Text (Text)
import Graphics.Vty.Attributes
-- | Parse a text attribute. This value should be a sections with the @fg@ and/or
-- @bg@ attributes. Otherwise it should be a color entry that will be used
-- for the foreground color. An empty sections value will result in 'defAttr'
attrSpec :: ValueSpec Attr
attrSpec = namedSpec "attr" $
withForeColor defAttr <$> colorSpec
<!> fullAttrSpec
fullAttrSpec :: ValueSpec Attr
fullAttrSpec = sectionsSpec "full-attr" $
do mbFg <- optSection' "fg" colorSpec "Foreground color"
mbBg <- optSection' "bg" colorSpec "Background color"
mbSt <- optSection' "style" stylesSpec "Terminal font style"
return ( aux withForeColor mbFg
$ aux withBackColor mbBg
$ aux (foldl withStyle) mbSt
$ defAttr)
where
aux f xs z = foldl f z xs
stylesSpec :: ValueSpec [Style]
stylesSpec = oneOrList styleSpec
styleSpec :: ValueSpec Style
styleSpec = namedSpec "style" $
blink <$ atomSpec "blink"
<!> bold <$ atomSpec "bold"
<!> dim <$ atomSpec "dim"
<!> italic <$ atomSpec "italic"
<!> reverseVideo <$ atomSpec "reverse-video"
<!> standout <$ atomSpec "standout"
<!> strikethrough<$ atomSpec "strikethrough"
<!> underline <$ atomSpec "underline"
-- | Parse a color. Support formats are:
--
-- * Number between 0-255
-- * Name of color
-- * RGB values of color as a list
colorSpec :: ValueSpec Color
colorSpec = namedSpec "color" (colorNumberSpec <!> colorNameSpec <!> rgbSpec)
colorNameSpec :: ValueSpec Color
colorNameSpec = customSpec "color name" anyAtomSpec
$ \name -> case HashMap.lookup name namedColors of
Nothing -> Left "unknown color"
Just c -> Right c
-- | Match integers between 0 and 255 as Terminal colors.
colorNumberSpec :: ValueSpec Color
colorNumberSpec = customSpec "terminal color" anySpec $ \i ->
if i < 0 then Left "minimum color is 0"
else if i < 16 then Right (ISOColor (fromInteger i))
else if i < 256 then Right (Color240 (fromInteger (i - 16)))
else Left "maximum color is 255"
-- | Configuration section that matches 3 integers in the range 0-255
-- representing red, green, and blue values.
rgbSpec :: ValueSpec Color
rgbSpec = customSpec "RGB" anySpec \case
[r,g,b] -> rgbColor <$> valid r <*> valid g <*> valid b
_ -> Left "expected 3 numbers"
where
valid x
| x < 0 = Left "minimum color value is 0"
| x < 256 = Right (x :: Integer)
| otherwise = Left "maximum color value is 255"
namedColors :: HashMap Text Color
namedColors = HashMap.fromList
[ ("black" , black )
, ("red" , red )
, ("green" , green )
, ("yellow" , yellow )
, ("blue" , blue )
, ("magenta" , magenta )
, ("cyan" , cyan )
, ("white" , white )
, ("bright-black" , brightBlack )
, ("bright-red" , brightRed )
, ("bright-green" , brightGreen )
, ("bright-yellow" , brightYellow )
, ("bright-blue" , brightBlue )
, ("bright-magenta", brightMagenta)
, ("bright-cyan" , brightCyan )
, ("bright-white" , brightWhite )
]