{-# Language OverloadedStrings #-}
{-# Language ApplicativeDo #-}

{-|
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 qualified Data.HashMap.Strict 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 (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 [Style]
mbSt <- Text -> ValueSpec [Style] -> Text -> SectionsSpec (Maybe [Style])
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
"style" ValueSpec [Style]
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 -> [Style] -> Attr) -> Maybe [Style] -> Attr -> Attr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> t a -> b -> b
aux ((Attr -> Style -> Attr) -> Attr -> [Style] -> Attr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Attr -> Style -> Attr
withStyle) Maybe [Style]
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 (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 [Style]
stylesSpec = ValueSpec Style -> ValueSpec [Style]
forall a. ValueSpec a -> ValueSpec [a]
oneOrList ValueSpec Style
styleSpec

styleSpec :: ValueSpec Style
styleSpec :: ValueSpec Style
styleSpec = Text -> ValueSpec Style -> ValueSpec Style
forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"style" (ValueSpec Style -> ValueSpec Style)
-> ValueSpec Style -> ValueSpec Style
forall a b. (a -> b) -> a -> b
$
      Style
blink        Style -> ValueSpec () -> ValueSpec Style
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"blink"
  ValueSpec Style -> ValueSpec Style -> ValueSpec Style
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Style
bold         Style -> ValueSpec () -> ValueSpec Style
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"bold"
  ValueSpec Style -> ValueSpec Style -> ValueSpec Style
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Style
dim          Style -> ValueSpec () -> ValueSpec Style
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"dim"
  ValueSpec Style -> ValueSpec Style -> ValueSpec Style
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Style
italic       Style -> ValueSpec () -> ValueSpec Style
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"italic"
  ValueSpec Style -> ValueSpec Style -> ValueSpec Style
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Style
reverseVideo Style -> ValueSpec () -> ValueSpec Style
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"reverse-video"
  ValueSpec Style -> ValueSpec Style -> ValueSpec Style
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Style
standout     Style -> ValueSpec () -> ValueSpec Style
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"standout"
  ValueSpec Style -> ValueSpec Style -> ValueSpec Style
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Style
strikethroughStyle -> ValueSpec () -> ValueSpec Style
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"strikethrough"
  ValueSpec Style -> ValueSpec Style -> ValueSpec Style
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Style
underline    Style -> ValueSpec () -> ValueSpec Style
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 (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec Color
colorNameSpec ValueSpec Color -> ValueSpec Color -> ValueSpec Color
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 (Style -> Color
ISOColor (Integer -> Style
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 (Style -> Color
Color240 (Integer -> Style
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 (([Integer] -> Either Text Color) -> ValueSpec Color)
-> ([Integer] -> Either Text Color) -> ValueSpec Color
forall a b. (a -> b) -> a -> b
$ \[Integer]
rgb ->
  case [Integer]
rgb of
    [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 (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 (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  )
  ]