{-# Language OverloadedStrings #-}
{-# Language ApplicativeDo #-}
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
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"
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
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"
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 )
]