{-# Language OverloadedStrings, ApplicativeDo, LambdaCase, BlockArguments #-}

{-|
Module      : Client.Configuration
Description : Client configuration format and operations
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module defines the top-level configuration information for the client.
-}

module Client.Configuration.Colors
  ( colorSpec
  , attrSpec
  ) where

import Config.Schema
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Text (Text)
import Graphics.Vty.Attributes

-- | Parse a text attribute. This value should be a sections with the @fg@ and/or
-- @bg@ attributes. Otherwise it should be a color entry that will be used
-- for the foreground color. An empty sections value will result in 'defAttr'
attrSpec :: ValueSpec Attr
attrSpec :: ValueSpec Attr
attrSpec = Text -> ValueSpec Attr -> ValueSpec Attr
forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"attr" (ValueSpec Attr -> ValueSpec Attr)
-> ValueSpec Attr -> ValueSpec Attr
forall a b. (a -> b) -> a -> b
$
           Attr -> Color -> Attr
withForeColor Attr
defAttr (Color -> Attr) -> ValueSpec Color -> ValueSpec Attr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec Color
colorSpec
       ValueSpec Attr -> ValueSpec Attr -> ValueSpec Attr
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec Attr
fullAttrSpec

fullAttrSpec :: ValueSpec Attr
fullAttrSpec :: ValueSpec Attr
fullAttrSpec = Text -> SectionsSpec Attr -> ValueSpec Attr
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"full-attr" (SectionsSpec Attr -> ValueSpec Attr)
-> SectionsSpec Attr -> ValueSpec Attr
forall a b. (a -> b) -> a -> b
$
  do Maybe Color
mbFg <- Text -> ValueSpec Color -> Text -> SectionsSpec (Maybe Color)
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
"fg"    ValueSpec Color
colorSpec Text
"Foreground color"
     Maybe Color
mbBg <- Text -> ValueSpec Color -> Text -> SectionsSpec (Maybe Color)
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
"bg"    ValueSpec Color
colorSpec Text
"Background color"
     Maybe [Word8]
mbSt <- Text -> ValueSpec [Word8] -> Text -> SectionsSpec (Maybe [Word8])
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
"style" ValueSpec [Word8]
stylesSpec Text
"Terminal font style"
     return ( (Attr -> Color -> Attr) -> Maybe Color -> Attr -> Attr
forall {t :: * -> *} {b} {a}.
Foldable t =>
(b -> a -> b) -> t a -> b -> b
aux Attr -> Color -> Attr
withForeColor Maybe Color
mbFg
            (Attr -> Attr) -> Attr -> Attr
forall a b. (a -> b) -> a -> b
$ (Attr -> Color -> Attr) -> Maybe Color -> Attr -> Attr
forall {t :: * -> *} {b} {a}.
Foldable t =>
(b -> a -> b) -> t a -> b -> b
aux Attr -> Color -> Attr
withBackColor Maybe Color
mbBg
            (Attr -> Attr) -> Attr -> Attr
forall a b. (a -> b) -> a -> b
$ (Attr -> [Word8] -> Attr) -> Maybe [Word8] -> Attr -> Attr
forall {t :: * -> *} {b} {a}.
Foldable t =>
(b -> a -> b) -> t a -> b -> b
aux ((Attr -> Word8 -> Attr) -> Attr -> [Word8] -> Attr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Attr -> Word8 -> Attr
withStyle) Maybe [Word8]
mbSt
            (Attr -> Attr) -> Attr -> Attr
forall a b. (a -> b) -> a -> b
$ Attr
defAttr)
  where
    aux :: (b -> a -> b) -> t a -> b -> b
aux b -> a -> b
f t a
xs b
z = (b -> a -> b) -> b -> t a -> b
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl b -> a -> b
f b
z t a
xs


stylesSpec :: ValueSpec [Style]
stylesSpec :: ValueSpec [Word8]
stylesSpec = ValueSpec Word8 -> ValueSpec [Word8]
forall a. ValueSpec a -> ValueSpec [a]
oneOrList ValueSpec Word8
styleSpec

styleSpec :: ValueSpec Style
styleSpec :: ValueSpec Word8
styleSpec = Text -> ValueSpec Word8 -> ValueSpec Word8
forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"style" (ValueSpec Word8 -> ValueSpec Word8)
-> ValueSpec Word8 -> ValueSpec Word8
forall a b. (a -> b) -> a -> b
$
      Word8
blink        Word8 -> ValueSpec () -> ValueSpec Word8
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"blink"
  ValueSpec Word8 -> ValueSpec Word8 -> ValueSpec Word8
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
bold         Word8 -> ValueSpec () -> ValueSpec Word8
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"bold"
  ValueSpec Word8 -> ValueSpec Word8 -> ValueSpec Word8
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
dim          Word8 -> ValueSpec () -> ValueSpec Word8
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"dim"
  ValueSpec Word8 -> ValueSpec Word8 -> ValueSpec Word8
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
italic       Word8 -> ValueSpec () -> ValueSpec Word8
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"italic"
  ValueSpec Word8 -> ValueSpec Word8 -> ValueSpec Word8
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
reverseVideo Word8 -> ValueSpec () -> ValueSpec Word8
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"reverse-video"
  ValueSpec Word8 -> ValueSpec Word8 -> ValueSpec Word8
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
standout     Word8 -> ValueSpec () -> ValueSpec Word8
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"standout"
  ValueSpec Word8 -> ValueSpec Word8 -> ValueSpec Word8
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
strikethroughWord8 -> ValueSpec () -> ValueSpec Word8
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"strikethrough"
  ValueSpec Word8 -> ValueSpec Word8 -> ValueSpec Word8
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
underline    Word8 -> ValueSpec () -> ValueSpec Word8
forall a b. a -> ValueSpec b -> ValueSpec a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"underline"


-- | Parse a color. Support formats are:
--
-- * Number between 0-255
-- * Name of color
-- * RGB values of color as a list
colorSpec :: ValueSpec Color
colorSpec :: ValueSpec Color
colorSpec = Text -> ValueSpec Color -> ValueSpec Color
forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"color" (ValueSpec Color
colorNumberSpec ValueSpec Color -> ValueSpec Color -> ValueSpec Color
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec Color
colorNameSpec ValueSpec Color -> ValueSpec Color -> ValueSpec Color
forall a. ValueSpec a -> ValueSpec a -> ValueSpec a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec Color
rgbSpec)

colorNameSpec :: ValueSpec Color
colorNameSpec :: ValueSpec Color
colorNameSpec = Text
-> ValueSpec Text -> (Text -> Either Text Color) -> ValueSpec Color
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"color name" ValueSpec Text
anyAtomSpec
              ((Text -> Either Text Color) -> ValueSpec Color)
-> (Text -> Either Text Color) -> ValueSpec Color
forall a b. (a -> b) -> a -> b
$ \Text
name -> case Text -> HashMap Text Color -> Maybe Color
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
name HashMap Text Color
namedColors of
                           Maybe Color
Nothing -> Text -> Either Text Color
forall a b. a -> Either a b
Left Text
"unknown color"
                           Just Color
c  -> Color -> Either Text Color
forall a b. b -> Either a b
Right Color
c

-- | Match integers between 0 and 255 as Terminal colors.
colorNumberSpec :: ValueSpec Color
colorNumberSpec :: ValueSpec Color
colorNumberSpec = Text
-> ValueSpec Integer
-> (Integer -> Either Text Color)
-> ValueSpec Color
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"terminal color" ValueSpec Integer
forall a. HasSpec a => ValueSpec a
anySpec ((Integer -> Either Text Color) -> ValueSpec Color)
-> (Integer -> Either Text Color) -> ValueSpec Color
forall a b. (a -> b) -> a -> b
$ \Integer
i ->
  if      Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<   Integer
0 then Text -> Either Text Color
forall a b. a -> Either a b
Left Text
"minimum color is 0"
  else if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
16 then Color -> Either Text Color
forall a b. b -> Either a b
Right (Word8 -> Color
ISOColor (Integer -> Word8
forall a. Num a => Integer -> a
fromInteger Integer
i))
  else if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
256 then Color -> Either Text Color
forall a b. b -> Either a b
Right (Word8 -> Color
Color240 (Integer -> Word8
forall a. Num a => Integer -> a
fromInteger (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
16)))
  else Text -> Either Text Color
forall a b. a -> Either a b
Left Text
"maximum color is 255"

-- | Configuration section that matches 3 integers in the range 0-255
-- representing red, green, and blue values.
rgbSpec :: ValueSpec Color
rgbSpec :: ValueSpec Color
rgbSpec = Text
-> ValueSpec [Integer]
-> ([Integer] -> Either Text Color)
-> ValueSpec Color
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"RGB" ValueSpec [Integer]
forall a. HasSpec a => ValueSpec a
anySpec \case
  [Integer
r,Integer
g,Integer
b] -> Integer -> Integer -> Integer -> Color
forall i. Integral i => i -> i -> i -> Color
rgbColor (Integer -> Integer -> Integer -> Color)
-> Either Text Integer -> Either Text (Integer -> Integer -> Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Either Text Integer
forall {a}. IsString a => Integer -> Either a Integer
valid Integer
r Either Text (Integer -> Integer -> Color)
-> Either Text Integer -> Either Text (Integer -> Color)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Integer -> Either Text Integer
forall {a}. IsString a => Integer -> Either a Integer
valid Integer
g Either Text (Integer -> Color)
-> Either Text Integer -> Either Text Color
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Integer -> Either Text Integer
forall {a}. IsString a => Integer -> Either a Integer
valid Integer
b
  [Integer]
_       -> Text -> Either Text Color
forall a b. a -> Either a b
Left Text
"expected 3 numbers"
  where
    valid :: Integer -> Either a Integer
valid Integer
x
      | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0     = a -> Either a Integer
forall a b. a -> Either a b
Left a
"minimum color value is 0"
      | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
256   = Integer -> Either a Integer
forall a b. b -> Either a b
Right (Integer
x :: Integer)
      | Bool
otherwise = a -> Either a Integer
forall a b. a -> Either a b
Left a
"maximum color value is 255"

namedColors :: HashMap Text Color
namedColors :: HashMap Text Color
namedColors = [(Text, Color)] -> HashMap Text Color
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
  [ (Text
"black"         , Color
black        )
  , (Text
"red"           , Color
red          )
  , (Text
"green"         , Color
green        )
  , (Text
"yellow"        , Color
yellow       )
  , (Text
"blue"          , Color
blue         )
  , (Text
"magenta"       , Color
magenta      )
  , (Text
"cyan"          , Color
cyan         )
  , (Text
"white"         , Color
white        )
  , (Text
"bright-black"  , Color
brightBlack  )
  , (Text
"bright-red"    , Color
brightRed    )
  , (Text
"bright-green"  , Color
brightGreen  )
  , (Text
"bright-yellow" , Color
brightYellow )
  , (Text
"bright-blue"   , Color
brightBlue   )
  , (Text
"bright-magenta", Color
brightMagenta)
  , (Text
"bright-cyan"   , Color
brightCyan   )
  , (Text
"bright-white"  , Color
brightWhite  )
  ]