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