{-# LANGUAGE NoImplicitPrelude #-}
module RIO.PrettyPrint.StylesUpdate
(
StylesUpdate (..)
, parseStylesUpdateFromString
, HasStylesUpdate (..)
) where
import Data.Aeson (FromJSON(..), withText)
import Data.Array.IArray (assocs)
import Data.Colour.SRGB (Colour, sRGB24)
import Data.Text as T (pack, unpack)
import RIO
import RIO.PrettyPrint.DefaultStyles (defaultStyles)
import RIO.PrettyPrint.Types (Style, StyleSpec)
import System.Console.ANSI.Types (BlinkSpeed (..), Color (..),
ColorIntensity (..), ConsoleIntensity (..), ConsoleLayer (..),
SGR (..), Underlining (..))
newtype StylesUpdate = StylesUpdate { stylesUpdate :: [(Style, StyleSpec)] }
deriving (Eq, Show)
instance Semigroup StylesUpdate where
StylesUpdate s1 <> StylesUpdate s2 = StylesUpdate (s2 <> s1)
instance Monoid StylesUpdate where
mempty = StylesUpdate []
mappend = (<>)
instance FromJSON StylesUpdate where
parseJSON = withText "StylesUpdate" $
return . parseStylesUpdateFromString . T.unpack
parseStylesUpdateFromString :: String -> StylesUpdate
parseStylesUpdateFromString s = StylesUpdate $ mapMaybe process table
where
table = do
w <- split ':' s
let (k, v') = break (== '=') w
case v' of
'=' : v -> return (T.pack k, parseCodes v)
_ -> []
process :: StyleSpec -> Maybe (Style, StyleSpec)
process (k, sgrs) = do
style <- lookup k styles
return (style, (k, sgrs))
styles :: [(Text, Style)]
styles = map (\(s, (k, _)) -> (k, s)) $ assocs defaultStyles
parseCodes :: String -> [SGR]
parseCodes [] = []
parseCodes s = parseCodes' c
where
s' = split ';' s
c :: [Word8]
c = mapMaybe readMaybe s'
parseCodes' :: [Word8] -> [SGR]
parseCodes' c = case codeToSGR c of
(Nothing, []) -> []
(Just sgr, []) -> [sgr]
(Nothing, cs) -> parseCodes' cs
(Just sgr, cs) -> sgr : parseCodes' cs
split :: Char -> String -> [String]
split c s = case rest of
[] -> [chunk]
_:rest1 -> chunk : split c rest1
where
(chunk, rest) = break (==c) s
codeToSGR :: [Word8] -> (Maybe SGR, [Word8])
codeToSGR [] = (Nothing, [])
codeToSGR (c:cs)
| c == 0 = (Just Reset, cs)
| c == 1 = (Just $ SetConsoleIntensity BoldIntensity, cs)
| c == 2 = (Just $ SetConsoleIntensity FaintIntensity, cs)
| c == 3 = (Just $ SetItalicized True, cs)
| c == 4 = (Just $ SetUnderlining SingleUnderline, cs)
| c == 5 = (Just $ SetBlinkSpeed SlowBlink, cs)
| c == 6 = (Just $ SetBlinkSpeed RapidBlink, cs)
| c == 7 = (Just $ SetSwapForegroundBackground True, cs)
| c == 8 = (Just $ SetVisible False, cs)
| c == 21 = (Just $ SetUnderlining DoubleUnderline, cs)
| c == 22 = (Just $ SetConsoleIntensity NormalIntensity, cs)
| c == 23 = (Just $ SetItalicized False, cs)
| c == 24 = (Just $ SetUnderlining NoUnderline, cs)
| c == 25 = (Just $ SetBlinkSpeed NoBlink, cs)
| c == 27 = (Just $ SetSwapForegroundBackground False, cs)
| c == 28 = (Just $ SetVisible True, cs)
| c >= 30 && c <= 37 =
(Just $ SetColor Foreground Dull $ codeToColor (c - 30), cs)
| c == 38 = case codeToRGB cs of
(Nothing, cs') -> (Nothing, cs')
(Just color, cs') -> (Just $ SetRGBColor Foreground color, cs')
| c >= 40 && c <= 47 =
(Just $ SetColor Background Dull $ codeToColor (c - 40), cs)
| c == 48 = case codeToRGB cs of
(Nothing, cs') -> (Nothing, cs')
(Just color, cs') -> (Just $ SetRGBColor Background color, cs')
| c >= 90 && c <= 97 =
(Just $ SetColor Foreground Vivid $ codeToColor (c - 90), cs)
| c >= 100 && c <= 107 =
(Just $ SetColor Background Vivid $ codeToColor (c - 100), cs)
| otherwise = (Nothing, cs)
codeToColor :: Word8 -> Color
codeToColor c
| c == 0 = Black
| c == 1 = Red
| c == 2 = Green
| c == 3 = Yellow
| c == 4 = Blue
| c == 5 = Magenta
| c == 6 = Cyan
| c == 7 = White
| otherwise = error "Error: codeToColor, code outside 0 to 7."
codeToRGB :: [Word8] -> (Maybe (Colour Float), [Word8])
codeToRGB [] = (Nothing, [])
codeToRGB (2:r:g:b:cs) = (Just $ sRGB24 r g b, cs)
codeToRGB cs = (Nothing, cs)
class HasStylesUpdate env where
stylesUpdateL :: Lens' env StylesUpdate
instance HasStylesUpdate StylesUpdate where
stylesUpdateL = id