{-# 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.Functor.Alt ((<!>))
import Data.Text (Text)
import Graphics.Vty.Attributes
attrSpec :: ValueSpecs Attr
attrSpec = namedSpec "attr" $
withForeColor defAttr <$> colorSpec
<!> fullAttrSpec
fullAttrSpec :: ValueSpecs Attr
fullAttrSpec = sectionsSpec "full-attr" $
do mbFg <- optSection' "fg" colorSpec "Foreground color"
mbBg <- optSection' "bg" colorSpec "Background color"
mbSt <- optSection' "style" stylesSpec "Terminal font style"
return ( aux withForeColor mbFg
$ aux withBackColor mbBg
$ aux (foldl withStyle) mbSt
$ defAttr)
where
aux f xs z = foldl f z xs
stylesSpec :: ValueSpecs [Style]
stylesSpec = oneOrList styleSpec
styleSpec :: ValueSpecs Style
styleSpec = namedSpec "style" $
blink <$ atomSpec "blink"
<!> bold <$ atomSpec "bold"
<!> dim <$ atomSpec "dim"
<!> reverseVideo <$ atomSpec "reverse-video"
<!> standout <$ atomSpec "standout"
<!> underline <$ atomSpec "underline"
colorSpec :: ValueSpecs Color
colorSpec = namedSpec "color" (colorNumberSpec <!> colorNameSpec <!> rgbSpec)
colorNameSpec :: ValueSpecs Color
colorNameSpec = customSpec "color name" anyAtomSpec (`HashMap.lookup` namedColors)
colorNumberSpec :: ValueSpecs Color
colorNumberSpec = customSpec "terminal color" valuesSpec $ \i ->
if i < 0 then Nothing
else if i < 16 then Just (ISOColor (fromInteger i))
else if i < 256 then Just (Color240 (fromInteger (i - 16)))
else Nothing
rgbSpec :: ValueSpecs Color
rgbSpec = customSpec "RGB" valuesSpec $ \rgb ->
case rgb of
[r,g,b] | valid r, valid g, valid b -> Just (rgbColor r g b)
_ -> Nothing
where
valid x = 0 <= x && x < (256 :: Integer)
namedColors :: HashMap Text Color
namedColors = HashMap.fromList
[ ("black" , black )
, ("red" , red )
, ("green" , green )
, ("yellow" , yellow )
, ("blue" , blue )
, ("magenta" , magenta )
, ("cyan" , cyan )
, ("white" , white )
, ("bright-black" , brightBlack )
, ("bright-red" , brightRed )
, ("bright-green" , brightGreen )
, ("bright-yellow" , brightYellow )
, ("bright-blue" , brightBlue )
, ("bright-magenta", brightMagenta)
, ("bright-cyan" , brightCyan )
, ("bright-white" , brightWhite )
]