{-# 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 :: Capability Int
termColors = String -> Capability Int
tiGetNum String
"colors"

data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan
            | White | ColorNumber Int
        deriving (Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
(Int -> Color -> ShowS)
-> (Color -> String) -> ([Color] -> ShowS) -> Show Color
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Color] -> ShowS
$cshowList :: [Color] -> ShowS
show :: Color -> String
$cshow :: Color -> String
showsPrec :: Int -> Color -> ShowS
$cshowsPrec :: Int -> Color -> ShowS
Show,Color -> Color -> Bool
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c== :: Color -> Color -> Bool
Eq,Eq Color
Eq Color
-> (Color -> Color -> Ordering)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Color)
-> (Color -> Color -> Color)
-> Ord Color
Color -> Color -> Bool
Color -> Color -> Ordering
Color -> Color -> Color
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Color -> Color -> Color
$cmin :: Color -> Color -> Color
max :: Color -> Color -> Color
$cmax :: Color -> Color -> Color
>= :: Color -> Color -> Bool
$c>= :: Color -> Color -> Bool
> :: Color -> Color -> Bool
$c> :: Color -> Color -> Bool
<= :: Color -> Color -> Bool
$c<= :: Color -> Color -> Bool
< :: Color -> Color -> Bool
$c< :: Color -> Color -> Bool
compare :: Color -> Color -> Ordering
$ccompare :: Color -> Color -> Ordering
Ord)



colorIntA, colorInt :: Color -> Int
colorIntA :: Color -> Int
colorIntA Color
c = case Color
c of
    Color
Black -> Int
0
    Color
Red -> Int
1
    Color
Green -> Int
2
    Color
Yellow -> Int
3
    Color
Blue -> Int
4
    Color
Magenta -> Int
5
    Color
Cyan -> Int
6
    Color
White -> Int
7
    ColorNumber Int
n -> Int
n
colorInt :: Color -> Int
colorInt Color
c = case Color
c of
    Color
Black -> Int
0
    Color
Blue -> Int
1
    Color
Green -> Int
2
    Color
Cyan -> Int
3
    Color
Red -> Int
4
    Color
Magenta -> Int
5
    Color
Yellow -> Int
6
    Color
White -> Int
7
    ColorNumber Int
n -> Int
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 :: forall s. TermStr s => Capability (Color -> s -> s)
withForegroundColor = Capability (Color -> s) -> Capability (Color -> s -> s)
forall s a.
TermStr s =>
Capability (a -> s) -> Capability (a -> s -> s)
withColorCmd Capability (Color -> s)
forall s. TermStr s => Capability (Color -> s)
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 :: forall s. TermStr s => Capability (Color -> s -> s)
withBackgroundColor = Capability (Color -> s) -> Capability (Color -> s -> s)
forall s a.
TermStr s =>
Capability (a -> s) -> Capability (a -> s -> s)
withColorCmd Capability (Color -> s)
forall s. TermStr s => Capability (Color -> s)
setBackgroundColor

withColorCmd :: TermStr s => Capability (a -> s)
            -> Capability (a -> s -> s)
withColorCmd :: forall s a.
TermStr s =>
Capability (a -> s) -> Capability (a -> s -> s)
withColorCmd Capability (a -> s)
getSet = do
    a -> s
set <- Capability (a -> s)
getSet
    s
restore <- Capability s
forall s. TermStr s => Capability s
restoreDefaultColors
    (a -> s -> s) -> Capability (a -> s -> s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> s -> s) -> Capability (a -> s -> s))
-> (a -> s -> s) -> Capability (a -> s -> s)
forall a b. (a -> b) -> a -> b
$ \a
c s
t -> a -> s
set a
c s -> s -> s
forall m. Monoid m => m -> m -> m
<#> s
t s -> s -> s
forall m. Monoid m => m -> m -> m
<#> s
restore

-- | Sets the foreground color of all further text output, using
-- either the @setaf@ or @setf@ capability.
setForegroundColor :: TermStr s => Capability (Color -> s)
setForegroundColor :: forall s. TermStr s => Capability (Color -> s)
setForegroundColor = Capability (Color -> s)
setaf Capability (Color -> s)
-> Capability (Color -> s) -> Capability (Color -> s)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Capability (Color -> s)
setf
    where
        setaf :: Capability (Color -> s)
setaf = ((Int -> s) -> Color -> s)
-> Capability (Int -> s) -> Capability (Color -> s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> s) -> (Color -> Int) -> Color -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Int
colorIntA) (Capability (Int -> s) -> Capability (Color -> s))
-> Capability (Int -> s) -> Capability (Color -> s)
forall a b. (a -> b) -> a -> b
$ String -> Capability (Int -> s)
forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"setaf"
        setf :: Capability (Color -> s)
setf = ((Int -> s) -> Color -> s)
-> Capability (Int -> s) -> Capability (Color -> s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> s) -> (Color -> Int) -> Color -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Int
colorInt) (Capability (Int -> s) -> Capability (Color -> s))
-> Capability (Int -> s) -> Capability (Color -> s)
forall a b. (a -> b) -> a -> b
$ String -> Capability (Int -> s)
forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"setf"

-- | Sets the background color of all further text output, using
-- either the @setab@ or @setb@ capability.
setBackgroundColor :: TermStr s => Capability (Color -> s)
setBackgroundColor :: forall s. TermStr s => Capability (Color -> s)
setBackgroundColor = Capability (Color -> s)
setab Capability (Color -> s)
-> Capability (Color -> s) -> Capability (Color -> s)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Capability (Color -> s)
setb
    where
        setab :: Capability (Color -> s)
setab = ((Int -> s) -> Color -> s)
-> Capability (Int -> s) -> Capability (Color -> s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> s) -> (Color -> Int) -> Color -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Int
colorIntA) (Capability (Int -> s) -> Capability (Color -> s))
-> Capability (Int -> s) -> Capability (Color -> s)
forall a b. (a -> b) -> a -> b
$ String -> Capability (Int -> s)
forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"setab"
        setb :: Capability (Color -> s)
setb = ((Int -> s) -> Color -> s)
-> Capability (Int -> s) -> Capability (Color -> s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> s) -> (Color -> Int) -> Color -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Int
colorInt) (Capability (Int -> s) -> Capability (Color -> s))
-> Capability (Int -> s) -> Capability (Color -> s)
forall a b. (a -> b) -> a -> b
$ String -> Capability (Int -> s)
forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"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 :: forall s. TermStr s => Capability s
restoreDefaultColors = String -> Capability s
forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"op"