1{-# LANGUAGE CPP #-}
2#if __GLASGOW_HASKELL__ >= 703
3{-# LANGUAGE Safe #-}
4#endif
5-- |
6-- Maintainer  : judah.jacobson@gmail.com
7-- Stability   : experimental
8-- Portability : portable (FFI)
9module System.Console.Terminfo.Color(
10                    termColors,
11                    Color(..),
12                    -- ColorPair,
13                    withForegroundColor,
14                    withBackgroundColor,
15                    -- withColorPair,
16                    setForegroundColor,
17                    setBackgroundColor,
18                    -- setColorPair,
19                    restoreDefaultColors
20                    ) where
21
22import System.Console.Terminfo.Base
23import Control.Monad (mplus)
24
25-- TODOs:
26-- examples
27-- try with xterm-256-colors (?)
28-- Color pairs, and HP terminals.
29-- TODO: this "white" looks more like a grey.  (What does ncurses do?)
30
31-- NB: for all the terminals in ncurses' terminfo.src, colors>=8 when it's
32-- set.  So we don't need to perform that check.
33
34-- | The maximum number of of colors on the screen.
35termColors :: Capability Int
36termColors = tiGetNum "colors"
37
38data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan
39            | White | ColorNumber Int
40        deriving (Show,Eq,Ord)
41
42
43
44colorIntA, colorInt :: Color -> Int
45colorIntA c = case c of
46    Black -> 0
47    Red -> 1
48    Green -> 2
49    Yellow -> 3
50    Blue -> 4
51    Magenta -> 5
52    Cyan -> 6
53    White -> 7
54    ColorNumber n -> n
55colorInt c = case c of
56    Black -> 0
57    Blue -> 1
58    Green -> 2
59    Cyan -> 3
60    Red -> 4
61    Magenta -> 5
62    Yellow -> 6
63    White -> 7
64    ColorNumber n -> n
65
66
67-- NB these aren't available on HP systems.
68-- also do we want to handle case when they're not available?
69
70-- | This capability temporarily sets the
71-- terminal's foreground color while outputting the given text, and
72-- then restores the terminal to its default foreground and background
73-- colors.
74withForegroundColor :: TermStr s => Capability (Color -> s -> s)
75withForegroundColor = withColorCmd setForegroundColor
76
77-- | This capability temporarily sets the
78-- terminal's background color while outputting the given text, and
79-- then restores the terminal to its default foreground and background
80-- colors.
81withBackgroundColor :: TermStr s => Capability (Color -> s -> s)
82withBackgroundColor = withColorCmd setBackgroundColor
83
84withColorCmd :: TermStr s => Capability (a -> s)
85            -> Capability (a -> s -> s)
86withColorCmd getSet = do
87    set <- getSet
88    restore <- restoreDefaultColors
89    return $ \c t -> set c <#> t <#> restore
90
91-- | Sets the foreground color of all further text output, using
92-- either the @setaf@ or @setf@ capability.
93setForegroundColor :: TermStr s => Capability (Color -> s)
94setForegroundColor = setaf `mplus` setf
95    where
96        setaf = fmap (. colorIntA) $ tiGetOutput1 "setaf"
97        setf = fmap (. colorInt) $ tiGetOutput1 "setf"
98
99-- | Sets the background color of all further text output, using
100-- either the @setab@ or @setb@ capability.
101setBackgroundColor :: TermStr s => Capability (Color -> s)
102setBackgroundColor = setab `mplus` setb
103    where
104        setab = fmap (. colorIntA) $ tiGetOutput1 "setab"
105        setb = fmap (. colorInt) $ tiGetOutput1 "setb"
106
107{-
108withColorPair :: TermStr s => Capability (ColorPair -> s -> s)
109withColorPair = withColorCmd setColorPair
110
111setColorPair :: TermStr s => Capability (ColorPair -> s)
112setColorPair = do
113    setf <- setForegroundColor
114    setb <- setBackgroundColor
115    return (\(f,b) -> setf f <#> setb b)
116
117type ColorPair = (Color,Color)
118-}
119
120
121-- | Restores foreground/background colors to their original
122-- settings.
123restoreDefaultColors :: TermStr s => Capability s
124restoreDefaultColors = tiGetOutput1 "op"
125