{-# 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 = forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"attr" forall a b. (a -> b) -> a -> b
$
           Attr -> Color -> Attr
withForeColor Attr
defAttr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSpec Color
colorSpec
       forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec Attr
fullAttrSpec

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

styleSpec :: ValueSpec Style
styleSpec :: ValueSpec Word8
styleSpec = forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"style" forall a b. (a -> b) -> a -> b
$
      Word8
blink        forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"blink"
  forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
bold         forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"bold"
  forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
dim          forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"dim"
  forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
italic       forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"italic"
  forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
reverseVideo forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"reverse-video"
  forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
standout     forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"standout"
  forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
strikethroughforall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueSpec ()
atomSpec Text
"strikethrough"
  forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> Word8
underline    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 = forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"color" (ValueSpec Color
colorNumberSpec forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec Color
colorNameSpec forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> ValueSpec Color
rgbSpec)

colorNameSpec :: ValueSpec Color
colorNameSpec :: ValueSpec Color
colorNameSpec = forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"color name" ValueSpec Text
anyAtomSpec
              forall a b. (a -> b) -> a -> b
$ \Text
name -> case 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 -> forall a b. a -> Either a b
Left Text
"unknown color"
                           Just Color
c  -> 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 = forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"terminal color" forall a. HasSpec a => ValueSpec a
anySpec forall a b. (a -> b) -> a -> b
$ \Integer
i ->
  if      Integer
i forall a. Ord a => a -> a -> Bool
<   Integer
0 then forall a b. a -> Either a b
Left Text
"minimum color is 0"
  else if Integer
i forall a. Ord a => a -> a -> Bool
<  Integer
16 then forall a b. b -> Either a b
Right (Word8 -> Color
ISOColor (forall a. Num a => Integer -> a
fromInteger Integer
i))
  else if Integer
i forall a. Ord a => a -> a -> Bool
< Integer
256 then forall a b. b -> Either a b
Right (Word8 -> Color
Color240 (forall a. Num a => Integer -> a
fromInteger (Integer
i forall a. Num a => a -> a -> a
- Integer
16)))
  else 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 = forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"RGB" forall a. HasSpec a => ValueSpec a
anySpec \case
  [Integer
r,Integer
g,Integer
b] -> forall i. Integral i => i -> i -> i -> Color
rgbColor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. IsString a => Integer -> Either a Integer
valid Integer
r forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a}. IsString a => Integer -> Either a Integer
valid Integer
g forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a}. IsString a => Integer -> Either a Integer
valid Integer
b
  [Integer]
_       -> forall a b. a -> Either a b
Left Text
"expected 3 numbers"
  where
    valid :: Integer -> Either a Integer
valid Integer
x
      | Integer
x forall a. Ord a => a -> a -> Bool
< Integer
0     = forall a b. a -> Either a b
Left a
"minimum color value is 0"
      | Integer
x forall a. Ord a => a -> a -> Bool
< Integer
256   = forall a b. b -> Either a b
Right (Integer
x :: Integer)
      | Bool
otherwise = forall a b. a -> Either a b
Left a
"maximum color value is 255"

namedColors :: HashMap Text Color
namedColors :: HashMap Text Color
namedColors = 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  )
  ]