{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Options.Applicative.Help.Style
  ( SetStyle (..)
  , ColorIntensity (..)
  , Layer (..)
  , ConsoleIntensity (..)
  , Underlining (..)
  , Italicized (..)
  , Color (..)
  , color
  , bgColor
  , colorDull
  , bgColorDull
  , bold
  , underlined
  , italicized
  , styleToRawText
  , defaultStyle
  ) where

import Control.Applicative
import Data.Maybe
import System.Console.ANSI (ConsoleIntensity (..), ColorIntensity (..), Underlining (..))

import qualified System.Console.ANSI    as ANSI

data SetStyle = SetStyle
  { SetStyle -> Bool
ansiReset             :: Bool
  , SetStyle -> Maybe (ColorIntensity, Color)
ansiForeground        :: Maybe (ColorIntensity, Color)  -- ^ Set the foreground color, or keep the old one.
  , SetStyle -> Maybe (ColorIntensity, Color)
ansiBackground        :: Maybe (ColorIntensity, Color)  -- ^ Set the background color, or keep the old one.
  , SetStyle -> Maybe ConsoleIntensity
ansiConsoleIntensity  :: Maybe ConsoleIntensity         -- ^ Adjust boldness
  , SetStyle -> Maybe Italicized
ansiItalics           :: Maybe Italicized               -- ^ Adjust italics
  , SetStyle -> Maybe Underlining
ansiUnderlining       :: Maybe Underlining              -- ^ Adjust underlining
  } deriving (SetStyle -> SetStyle -> Bool
(SetStyle -> SetStyle -> Bool)
-> (SetStyle -> SetStyle -> Bool) -> Eq SetStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SetStyle -> SetStyle -> Bool
$c/= :: SetStyle -> SetStyle -> Bool
== :: SetStyle -> SetStyle -> Bool
$c== :: SetStyle -> SetStyle -> Bool
Eq, Eq SetStyle
Eq SetStyle
-> (SetStyle -> SetStyle -> Ordering)
-> (SetStyle -> SetStyle -> Bool)
-> (SetStyle -> SetStyle -> Bool)
-> (SetStyle -> SetStyle -> Bool)
-> (SetStyle -> SetStyle -> Bool)
-> (SetStyle -> SetStyle -> SetStyle)
-> (SetStyle -> SetStyle -> SetStyle)
-> Ord SetStyle
SetStyle -> SetStyle -> Bool
SetStyle -> SetStyle -> Ordering
SetStyle -> SetStyle -> SetStyle
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 :: SetStyle -> SetStyle -> SetStyle
$cmin :: SetStyle -> SetStyle -> SetStyle
max :: SetStyle -> SetStyle -> SetStyle
$cmax :: SetStyle -> SetStyle -> SetStyle
>= :: SetStyle -> SetStyle -> Bool
$c>= :: SetStyle -> SetStyle -> Bool
> :: SetStyle -> SetStyle -> Bool
$c> :: SetStyle -> SetStyle -> Bool
<= :: SetStyle -> SetStyle -> Bool
$c<= :: SetStyle -> SetStyle -> Bool
< :: SetStyle -> SetStyle -> Bool
$c< :: SetStyle -> SetStyle -> Bool
compare :: SetStyle -> SetStyle -> Ordering
$ccompare :: SetStyle -> SetStyle -> Ordering
$cp1Ord :: Eq SetStyle
Ord, Int -> SetStyle -> ShowS
[SetStyle] -> ShowS
SetStyle -> String
(Int -> SetStyle -> ShowS)
-> (SetStyle -> String) -> ([SetStyle] -> ShowS) -> Show SetStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SetStyle] -> ShowS
$cshowList :: [SetStyle] -> ShowS
show :: SetStyle -> String
$cshow :: SetStyle -> String
showsPrec :: Int -> SetStyle -> ShowS
$cshowsPrec :: Int -> SetStyle -> ShowS
Show)

instance Monoid SetStyle where
    mempty :: SetStyle
mempty = Bool
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Italicized
-> Maybe Underlining
-> SetStyle
SetStyle Bool
False Maybe (ColorIntensity, Color)
forall a. Maybe a
Nothing Maybe (ColorIntensity, Color)
forall a. Maybe a
Nothing Maybe ConsoleIntensity
forall a. Maybe a
Nothing Maybe Italicized
forall a. Maybe a
Nothing Maybe Underlining
forall a. Maybe a
Nothing
    mappend :: SetStyle -> SetStyle -> SetStyle
mappend = SetStyle -> SetStyle -> SetStyle
forall a. Semigroup a => a -> a -> a
(<>)

defaultStyle :: SetStyle
defaultStyle :: SetStyle
defaultStyle = SetStyle :: Bool
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Italicized
-> Maybe Underlining
-> SetStyle
SetStyle
  { ansiReset :: Bool
ansiReset             = Bool
True
  , ansiForeground :: Maybe (ColorIntensity, Color)
ansiForeground        = Maybe (ColorIntensity, Color)
forall a. Maybe a
Nothing
  , ansiBackground :: Maybe (ColorIntensity, Color)
ansiBackground        = Maybe (ColorIntensity, Color)
forall a. Maybe a
Nothing
  , ansiConsoleIntensity :: Maybe ConsoleIntensity
ansiConsoleIntensity  = ConsoleIntensity -> Maybe ConsoleIntensity
forall a. a -> Maybe a
Just ConsoleIntensity
NormalIntensity
  , ansiItalics :: Maybe Italicized
ansiItalics           = Italicized -> Maybe Italicized
forall a. a -> Maybe a
Just Italicized
NoItalics
  , ansiUnderlining :: Maybe Underlining
ansiUnderlining       = Underlining -> Maybe Underlining
forall a. a -> Maybe a
Just Underlining
NoUnderline
  }

isItalicised :: Italicized -> Bool
isItalicised :: Italicized -> Bool
isItalicised Italicized
Italicized = Bool
True
isItalicised Italicized
NoItalics = Bool
False

styleToRawText :: SetStyle -> String
styleToRawText :: SetStyle -> String
styleToRawText = [SGR] -> String
ANSI.setSGRCode ([SGR] -> String) -> (SetStyle -> [SGR]) -> SetStyle -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetStyle -> [SGR]
stylesToSgrs
  where
    stylesToSgrs :: SetStyle -> [ANSI.SGR]
    stylesToSgrs :: SetStyle -> [SGR]
stylesToSgrs (SetStyle Bool
r Maybe (ColorIntensity, Color)
fg Maybe (ColorIntensity, Color)
bg Maybe ConsoleIntensity
b Maybe Italicized
i Maybe Underlining
u) = [Maybe SGR] -> [SGR]
forall a. [Maybe a] -> [a]
catMaybes
        [ if Bool
r then SGR -> Maybe SGR
forall a. a -> Maybe a
Just SGR
ANSI.Reset else Maybe SGR
forall a. Maybe a
Nothing
        , ((ColorIntensity, Color) -> SGR)
-> Maybe (ColorIntensity, Color) -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ColorIntensity
intensity, Color
c) -> ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
intensity (Color -> Color
convertColor Color
c)) Maybe (ColorIntensity, Color)
fg
        , ((ColorIntensity, Color) -> SGR)
-> Maybe (ColorIntensity, Color) -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ColorIntensity
intensity, Color
c) -> ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Background ColorIntensity
intensity (Color -> Color
convertColor Color
c)) Maybe (ColorIntensity, Color)
bg
        , (ConsoleIntensity -> SGR) -> Maybe ConsoleIntensity -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConsoleIntensity -> SGR
ANSI.SetConsoleIntensity Maybe ConsoleIntensity
b
        , (Italicized -> SGR) -> Maybe Italicized -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> SGR
ANSI.SetItalicized (Bool -> SGR) -> (Italicized -> Bool) -> Italicized -> SGR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Italicized -> Bool
isItalicised) Maybe Italicized
i
        , (Underlining -> SGR) -> Maybe Underlining -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Underlining -> SGR
ANSI.SetUnderlining Maybe Underlining
u
        ]

    convertColor :: Color -> ANSI.Color
    convertColor :: Color -> Color
convertColor = \Color
c -> case Color
c of
        Color
Black   -> Color
ANSI.Black
        Color
Red     -> Color
ANSI.Red
        Color
Green   -> Color
ANSI.Green
        Color
Yellow  -> Color
ANSI.Yellow
        Color
Blue    -> Color
ANSI.Blue
        Color
Magenta -> Color
ANSI.Magenta
        Color
Cyan    -> Color
ANSI.Cyan
        Color
White   -> Color
ANSI.White

data Layer = Foreground | Background
    deriving (Layer -> Layer -> Bool
(Layer -> Layer -> Bool) -> (Layer -> Layer -> Bool) -> Eq Layer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Layer -> Layer -> Bool
$c/= :: Layer -> Layer -> Bool
== :: Layer -> Layer -> Bool
$c== :: Layer -> Layer -> Bool
Eq, Eq Layer
Eq Layer
-> (Layer -> Layer -> Ordering)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Layer)
-> (Layer -> Layer -> Layer)
-> Ord Layer
Layer -> Layer -> Bool
Layer -> Layer -> Ordering
Layer -> Layer -> Layer
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 :: Layer -> Layer -> Layer
$cmin :: Layer -> Layer -> Layer
max :: Layer -> Layer -> Layer
$cmax :: Layer -> Layer -> Layer
>= :: Layer -> Layer -> Bool
$c>= :: Layer -> Layer -> Bool
> :: Layer -> Layer -> Bool
$c> :: Layer -> Layer -> Bool
<= :: Layer -> Layer -> Bool
$c<= :: Layer -> Layer -> Bool
< :: Layer -> Layer -> Bool
$c< :: Layer -> Layer -> Bool
compare :: Layer -> Layer -> Ordering
$ccompare :: Layer -> Layer -> Ordering
$cp1Ord :: Eq Layer
Ord, Int -> Layer -> ShowS
[Layer] -> ShowS
Layer -> String
(Int -> Layer -> ShowS)
-> (Layer -> String) -> ([Layer] -> ShowS) -> Show Layer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Layer] -> ShowS
$cshowList :: [Layer] -> ShowS
show :: Layer -> String
$cshow :: Layer -> String
showsPrec :: Int -> Layer -> ShowS
$cshowsPrec :: Int -> Layer -> ShowS
Show)

data Italicized = Italicized | NoItalics deriving (Italicized -> Italicized -> Bool
(Italicized -> Italicized -> Bool)
-> (Italicized -> Italicized -> Bool) -> Eq Italicized
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Italicized -> Italicized -> Bool
$c/= :: Italicized -> Italicized -> Bool
== :: Italicized -> Italicized -> Bool
$c== :: Italicized -> Italicized -> Bool
Eq, Eq Italicized
Eq Italicized
-> (Italicized -> Italicized -> Ordering)
-> (Italicized -> Italicized -> Bool)
-> (Italicized -> Italicized -> Bool)
-> (Italicized -> Italicized -> Bool)
-> (Italicized -> Italicized -> Bool)
-> (Italicized -> Italicized -> Italicized)
-> (Italicized -> Italicized -> Italicized)
-> Ord Italicized
Italicized -> Italicized -> Bool
Italicized -> Italicized -> Ordering
Italicized -> Italicized -> Italicized
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 :: Italicized -> Italicized -> Italicized
$cmin :: Italicized -> Italicized -> Italicized
max :: Italicized -> Italicized -> Italicized
$cmax :: Italicized -> Italicized -> Italicized
>= :: Italicized -> Italicized -> Bool
$c>= :: Italicized -> Italicized -> Bool
> :: Italicized -> Italicized -> Bool
$c> :: Italicized -> Italicized -> Bool
<= :: Italicized -> Italicized -> Bool
$c<= :: Italicized -> Italicized -> Bool
< :: Italicized -> Italicized -> Bool
$c< :: Italicized -> Italicized -> Bool
compare :: Italicized -> Italicized -> Ordering
$ccompare :: Italicized -> Italicized -> Ordering
$cp1Ord :: Eq Italicized
Ord, Int -> Italicized -> ShowS
[Italicized] -> ShowS
Italicized -> String
(Int -> Italicized -> ShowS)
-> (Italicized -> String)
-> ([Italicized] -> ShowS)
-> Show Italicized
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Italicized] -> ShowS
$cshowList :: [Italicized] -> ShowS
show :: Italicized -> String
$cshow :: Italicized -> String
showsPrec :: Int -> Italicized -> ShowS
$cshowsPrec :: Int -> Italicized -> ShowS
Show)

instance Semigroup SetStyle where
  SetStyle
cs1 <> :: SetStyle -> SetStyle -> SetStyle
<> SetStyle
cs2 = SetStyle :: Bool
-> Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color)
-> Maybe ConsoleIntensity
-> Maybe Italicized
-> Maybe Underlining
-> SetStyle
SetStyle
    { ansiReset :: Bool
ansiReset             = SetStyle -> Bool
ansiReset             SetStyle
cs1 Bool -> Bool -> Bool
&&  SetStyle -> Bool
ansiReset             SetStyle
cs2
    , ansiForeground :: Maybe (ColorIntensity, Color)
ansiForeground        = SetStyle -> Maybe (ColorIntensity, Color)
ansiForeground        SetStyle
cs1 Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SetStyle -> Maybe (ColorIntensity, Color)
ansiForeground        SetStyle
cs2
    , ansiBackground :: Maybe (ColorIntensity, Color)
ansiBackground        = SetStyle -> Maybe (ColorIntensity, Color)
ansiBackground        SetStyle
cs1 Maybe (ColorIntensity, Color)
-> Maybe (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SetStyle -> Maybe (ColorIntensity, Color)
ansiBackground        SetStyle
cs2
    , ansiConsoleIntensity :: Maybe ConsoleIntensity
ansiConsoleIntensity  = SetStyle -> Maybe ConsoleIntensity
ansiConsoleIntensity  SetStyle
cs1 Maybe ConsoleIntensity
-> Maybe ConsoleIntensity -> Maybe ConsoleIntensity
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SetStyle -> Maybe ConsoleIntensity
ansiConsoleIntensity  SetStyle
cs2
    , ansiItalics :: Maybe Italicized
ansiItalics           = SetStyle -> Maybe Italicized
ansiItalics           SetStyle
cs1 Maybe Italicized -> Maybe Italicized -> Maybe Italicized
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SetStyle -> Maybe Italicized
ansiItalics           SetStyle
cs2
    , ansiUnderlining :: Maybe Underlining
ansiUnderlining       = SetStyle -> Maybe Underlining
ansiUnderlining       SetStyle
cs1 Maybe Underlining -> Maybe Underlining -> Maybe Underlining
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SetStyle -> Maybe Underlining
ansiUnderlining       SetStyle
cs2
    }

data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
    deriving (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
$cp1Ord :: Eq Color
Ord, 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)

-- | Style the foreground with a vivid color.
color :: Color -> SetStyle
color :: Color -> SetStyle
color Color
c = SetStyle
forall a. Monoid a => a
mempty { ansiForeground :: Maybe (ColorIntensity, Color)
ansiForeground = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
Vivid, Color
c) }

-- | Style the background with a vivid color.
bgColor :: Color -> SetStyle
bgColor :: Color -> SetStyle
bgColor Color
c =  SetStyle
forall a. Monoid a => a
mempty { ansiBackground :: Maybe (ColorIntensity, Color)
ansiBackground = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
Vivid, Color
c) }

-- | Style the foreground with a dull color.
colorDull :: Color -> SetStyle
colorDull :: Color -> SetStyle
colorDull Color
c =  SetStyle
forall a. Monoid a => a
mempty { ansiForeground :: Maybe (ColorIntensity, Color)
ansiForeground = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
Dull, Color
c) }

-- | Style the background with a dull color.
bgColorDull :: Color -> SetStyle
bgColorDull :: Color -> SetStyle
bgColorDull Color
c =  SetStyle
forall a. Monoid a => a
mempty { ansiBackground :: Maybe (ColorIntensity, Color)
ansiBackground = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
Dull, Color
c) }

-- | Render in __bold__.
bold :: SetStyle
bold :: SetStyle
bold = SetStyle
forall a. Monoid a => a
mempty { ansiConsoleIntensity :: Maybe ConsoleIntensity
ansiConsoleIntensity = ConsoleIntensity -> Maybe ConsoleIntensity
forall a. a -> Maybe a
Just ConsoleIntensity
BoldIntensity }

-- | Render in /italics/.
italicized :: SetStyle
italicized :: SetStyle
italicized = SetStyle
forall a. Monoid a => a
mempty { ansiItalics :: Maybe Italicized
ansiItalics = Italicized -> Maybe Italicized
forall a. a -> Maybe a
Just Italicized
Italicized }

-- | Render underlined.
underlined :: SetStyle
underlined :: SetStyle
underlined = SetStyle
forall a. Monoid a => a
mempty { ansiUnderlining :: Maybe Underlining
ansiUnderlining = Underlining -> Maybe Underlining
forall a. a -> Maybe a
Just Underlining
SingleUnderline }