{-# LANGUAGE CPP #-} #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"