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
113
114
115
116
117
118
119
120
121
122
123
|
#if __GLASGOW_HASKELL__ >= 703
{-# LANGUAGE Safe #-}
#endif
-- |
-- Maintainer : judah.jacobson@gmail.com
-- Stability : experimental
-- Portability : portable (FFI)
module System.Console.Terminfo.Color(
termColors,
Color(..),
-- ColorPair,
withForegroundColor,
withBackgroundColor,
-- withColorPair,
setForegroundColor,
setBackgroundColor,
-- setColorPair,
restoreDefaultColors
) where
import System.Console.Terminfo.Base
import Control.Monad (mplus)
-- TODOs:
-- examples
-- try with xterm-256-colors (?)
-- Color pairs, and HP terminals.
-- TODO: this "white" looks more like a grey. (What does ncurses do?)
-- NB: for all the terminals in ncurses' terminfo.src, colors>=8 when it's
-- set. So we don't need to perform that check.
-- | The maximum number of of colors on the screen.
termColors :: Capability Int
termColors = tiGetNum "colors"
data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan
| White | ColorNumber Int
deriving (Show,Eq,Ord)
colorIntA, colorInt :: Color -> Int
colorIntA c = case c of
Black -> 0
Red -> 1
Green -> 2
Yellow -> 3
Blue -> 4
Magenta -> 5
Cyan -> 6
White -> 7
ColorNumber n -> n
colorInt c = case c of
Black -> 0
Blue -> 1
Green -> 2
Cyan -> 3
Red -> 4
Magenta -> 5
Yellow -> 6
White -> 7
ColorNumber n -> n
-- NB these aren't available on HP systems.
-- also do we want to handle case when they're not available?
-- | This capability temporarily sets the
-- terminal's foreground color while outputting the given text, and
-- then restores the terminal to its default foreground and background
-- colors.
withForegroundColor :: TermStr s => Capability (Color -> s -> s)
withForegroundColor = withColorCmd setForegroundColor
-- | This capability temporarily sets the
-- terminal's background color while outputting the given text, and
-- then restores the terminal to its default foreground and background
-- colors.
withBackgroundColor :: TermStr s => Capability (Color -> s -> s)
withBackgroundColor = withColorCmd setBackgroundColor
withColorCmd :: TermStr s => Capability (a -> s)
-> Capability (a -> s -> s)
withColorCmd getSet = do
set <- getSet
restore <- restoreDefaultColors
return $ \c t -> set c <#> t <#> restore
-- | Sets the foreground color of all further text output, using
-- either the @setaf@ or @setf@ capability.
setForegroundColor :: TermStr s => Capability (Color -> s)
setForegroundColor = setaf `mplus` setf
where
setaf = fmap (. colorIntA) $ tiGetOutput1 "setaf"
setf = fmap (. colorInt) $ tiGetOutput1 "setf"
-- | Sets the background color of all further text output, using
-- either the @setab@ or @setb@ capability.
setBackgroundColor :: TermStr s => Capability (Color -> s)
setBackgroundColor = setab `mplus` setb
where
setab = fmap (. colorIntA) $ tiGetOutput1 "setab"
setb = fmap (. colorInt) $ tiGetOutput1 "setb"
{-
withColorPair :: TermStr s => Capability (ColorPair -> s -> s)
withColorPair = withColorCmd setColorPair
setColorPair :: TermStr s => Capability (ColorPair -> s)
setColorPair = do
setf <- setForegroundColor
setb <- setBackgroundColor
return (\(f,b) -> setf f <#> setb b)
type ColorPair = (Color,Color)
-}
-- | Restores foreground/background colors to their original
-- settings.
restoreDefaultColors :: TermStr s => Capability s
restoreDefaultColors = tiGetOutput1 "op"
|
