{-# 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, (Text, [SGR]))]
stylesUpdate :: [(Style, StyleSpec)] }
deriving (StylesUpdate -> StylesUpdate -> Bool
(StylesUpdate -> StylesUpdate -> Bool)
-> (StylesUpdate -> StylesUpdate -> Bool) -> Eq StylesUpdate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StylesUpdate -> StylesUpdate -> Bool
== :: StylesUpdate -> StylesUpdate -> Bool
$c/= :: StylesUpdate -> StylesUpdate -> Bool
/= :: StylesUpdate -> StylesUpdate -> Bool
Eq, Int -> StylesUpdate -> ShowS
[StylesUpdate] -> ShowS
StylesUpdate -> String
(Int -> StylesUpdate -> ShowS)
-> (StylesUpdate -> String)
-> ([StylesUpdate] -> ShowS)
-> Show StylesUpdate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StylesUpdate -> ShowS
showsPrec :: Int -> StylesUpdate -> ShowS
$cshow :: StylesUpdate -> String
show :: StylesUpdate -> String
$cshowList :: [StylesUpdate] -> ShowS
showList :: [StylesUpdate] -> ShowS
Show)
instance Semigroup StylesUpdate where
StylesUpdate [(Style, (Text, [SGR]))]
s1 <> :: StylesUpdate -> StylesUpdate -> StylesUpdate
<> StylesUpdate [(Style, (Text, [SGR]))]
s2 = [(Style, (Text, [SGR]))] -> StylesUpdate
StylesUpdate ([(Style, (Text, [SGR]))]
s2 [(Style, (Text, [SGR]))]
-> [(Style, (Text, [SGR]))] -> [(Style, (Text, [SGR]))]
forall a. Semigroup a => a -> a -> a
<> [(Style, (Text, [SGR]))]
s1)
instance Monoid StylesUpdate where
mempty :: StylesUpdate
mempty = [(Style, (Text, [SGR]))] -> StylesUpdate
StylesUpdate []
mappend :: StylesUpdate -> StylesUpdate -> StylesUpdate
mappend = StylesUpdate -> StylesUpdate -> StylesUpdate
forall a. Semigroup a => a -> a -> a
(<>)
instance FromJSON StylesUpdate where
parseJSON :: Value -> Parser StylesUpdate
parseJSON = String
-> (Text -> Parser StylesUpdate) -> Value -> Parser StylesUpdate
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"StylesUpdate" ((Text -> Parser StylesUpdate) -> Value -> Parser StylesUpdate)
-> (Text -> Parser StylesUpdate) -> Value -> Parser StylesUpdate
forall a b. (a -> b) -> a -> b
$
StylesUpdate -> Parser StylesUpdate
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (StylesUpdate -> Parser StylesUpdate)
-> (Text -> StylesUpdate) -> Text -> Parser StylesUpdate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StylesUpdate
parseStylesUpdateFromString (String -> StylesUpdate)
-> (Text -> String) -> Text -> StylesUpdate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
parseStylesUpdateFromString :: String -> StylesUpdate
parseStylesUpdateFromString :: String -> StylesUpdate
parseStylesUpdateFromString String
s = [(Style, (Text, [SGR]))] -> StylesUpdate
StylesUpdate ([(Style, (Text, [SGR]))] -> StylesUpdate)
-> [(Style, (Text, [SGR]))] -> StylesUpdate
forall a b. (a -> b) -> a -> b
$ ((Text, [SGR]) -> Maybe (Style, (Text, [SGR])))
-> [(Text, [SGR])] -> [(Style, (Text, [SGR]))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, [SGR]) -> Maybe (Style, (Text, [SGR]))
process [(Text, [SGR])]
table
where
table :: [(Text, [SGR])]
table = do
String
w <- Char -> String -> [String]
split Char
':' String
s
let (String
k, String
v') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') String
w
case String
v' of
Char
'=' : String
v -> (Text, [SGR]) -> [(Text, [SGR])]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
T.pack String
k, String -> [SGR]
parseCodes String
v)
String
_ -> []
process :: StyleSpec -> Maybe (Style, StyleSpec)
process :: (Text, [SGR]) -> Maybe (Style, (Text, [SGR]))
process (Text
k, [SGR]
sgrs) = do
Style
style <- Text -> [(Text, Style)] -> Maybe Style
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Style)]
styles
(Style, (Text, [SGR])) -> Maybe (Style, (Text, [SGR]))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Style
style, (Text
k, [SGR]
sgrs))
styles :: [(Text, Style)]
styles :: [(Text, Style)]
styles = ((Style, (Text, [SGR])) -> (Text, Style))
-> [(Style, (Text, [SGR]))] -> [(Text, Style)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Style
s, (Text
k, [SGR]
_)) -> (Text
k, Style
s)) ([(Style, (Text, [SGR]))] -> [(Text, Style)])
-> [(Style, (Text, [SGR]))] -> [(Text, Style)]
forall a b. (a -> b) -> a -> b
$ Array Style (Text, [SGR]) -> [(Style, (Text, [SGR]))]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs Array Style (Text, [SGR])
defaultStyles
parseCodes :: String -> [SGR]
parseCodes :: String -> [SGR]
parseCodes [] = []
parseCodes String
s = [Word8] -> [SGR]
parseCodes' [Word8]
c
where
s' :: [String]
s' = Char -> String -> [String]
split Char
';' String
s
c :: [Word8]
c :: [Word8]
c = (String -> Maybe Word8) -> [String] -> [Word8]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe Word8
forall a. Read a => String -> Maybe a
readMaybe [String]
s'
parseCodes' :: [Word8] -> [SGR]
parseCodes' :: [Word8] -> [SGR]
parseCodes' [Word8]
c = case [Word8] -> (Maybe SGR, [Word8])
codeToSGR [Word8]
c of
(Maybe SGR
Nothing, []) -> []
(Just SGR
sgr, []) -> [SGR
sgr]
(Maybe SGR
Nothing, [Word8]
cs) -> [Word8] -> [SGR]
parseCodes' [Word8]
cs
(Just SGR
sgr, [Word8]
cs) -> SGR
sgr SGR -> [SGR] -> [SGR]
forall a. a -> [a] -> [a]
: [Word8] -> [SGR]
parseCodes' [Word8]
cs
split :: Char -> String -> [String]
split :: Char -> String -> [String]
split Char
c String
s = case String
rest of
[] -> [String
chunk]
Char
_:String
rest1 -> String
chunk String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Char -> String -> [String]
split Char
c String
rest1
where
(String
chunk, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c) String
s
codeToSGR :: [Word8] -> (Maybe SGR, [Word8])
codeToSGR :: [Word8] -> (Maybe SGR, [Word8])
codeToSGR [] = (Maybe SGR
forall a. Maybe a
Nothing, [])
codeToSGR (Word8
c:[Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just SGR
Reset, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
1 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
2 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
FaintIntensity, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
3 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetItalicized Bool
True, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
4 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Underlining -> SGR
SetUnderlining Underlining
SingleUnderline, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
5 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ BlinkSpeed -> SGR
SetBlinkSpeed BlinkSpeed
SlowBlink, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
6 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ BlinkSpeed -> SGR
SetBlinkSpeed BlinkSpeed
RapidBlink, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
7 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetSwapForegroundBackground Bool
True, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
8 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetVisible Bool
False, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
21 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Underlining -> SGR
SetUnderlining Underlining
DoubleUnderline, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
22 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
23 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetItalicized Bool
False, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
24 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Underlining -> SGR
SetUnderlining Underlining
NoUnderline, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
25 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ BlinkSpeed -> SGR
SetBlinkSpeed BlinkSpeed
NoBlink, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
27 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetSwapForegroundBackground Bool
False, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
28 = (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetVisible Bool
True, [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
30 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
37 =
(SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull (Color -> SGR) -> Color -> SGR
forall a b. (a -> b) -> a -> b
$ Word8 -> Color
codeToColor (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
30), [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
38 = case [Word8] -> (Maybe (Colour Float), [Word8])
codeToRGB [Word8]
cs of
(Maybe (Colour Float)
Nothing, [Word8]
cs') -> (Maybe SGR
forall a. Maybe a
Nothing, [Word8]
cs')
(Just Colour Float
color, [Word8]
cs') -> (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground Colour Float
color, [Word8]
cs')
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
40 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
47 =
(SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
Dull (Color -> SGR) -> Color -> SGR
forall a b. (a -> b) -> a -> b
$ Word8 -> Color
codeToColor (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
40), [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
48 = case [Word8] -> (Maybe (Colour Float), [Word8])
codeToRGB [Word8]
cs of
(Maybe (Colour Float)
Nothing, [Word8]
cs') -> (Maybe SGR
forall a. Maybe a
Nothing, [Word8]
cs')
(Just Colour Float
color, [Word8]
cs') -> (SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Background Colour Float
color, [Word8]
cs')
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
90 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
97 =
(SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid (Color -> SGR) -> Color -> SGR
forall a b. (a -> b) -> a -> b
$ Word8 -> Color
codeToColor (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
90), [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
100 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
107 =
(SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
Vivid (Color -> SGR) -> Color -> SGR
forall a b. (a -> b) -> a -> b
$ Word8 -> Color
codeToColor (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
100), [Word8]
cs)
| Bool
otherwise = (Maybe SGR
forall a. Maybe a
Nothing, [Word8]
cs)
codeToColor :: Word8 -> Color
codeToColor :: Word8 -> Color
codeToColor Word8
c
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 = Color
Black
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
1 = Color
Red
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
2 = Color
Green
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
3 = Color
Yellow
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
4 = Color
Blue
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
5 = Color
Magenta
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
6 = Color
Cyan
| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
7 = Color
White
| Bool
otherwise = String -> Color
forall a. HasCallStack => String -> a
error String
"Error: codeToColor, code outside 0 to 7."
codeToRGB :: [Word8] -> (Maybe (Colour Float), [Word8])
codeToRGB :: [Word8] -> (Maybe (Colour Float), [Word8])
codeToRGB [] = (Maybe (Colour Float)
forall a. Maybe a
Nothing, [])
codeToRGB (Word8
2:Word8
r:Word8
g:Word8
b:[Word8]
cs) = (Colour Float -> Maybe (Colour Float)
forall a. a -> Maybe a
Just (Colour Float -> Maybe (Colour Float))
-> Colour Float -> Maybe (Colour Float)
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Colour Float
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
r Word8
g Word8
b, [Word8]
cs)
codeToRGB [Word8]
cs = (Maybe (Colour Float)
forall a. Maybe a
Nothing, [Word8]
cs)
class HasStylesUpdate env where
stylesUpdateL :: Lens' env StylesUpdate
instance HasStylesUpdate StylesUpdate where
stylesUpdateL :: Lens' StylesUpdate StylesUpdate
stylesUpdateL = (StylesUpdate -> f StylesUpdate) -> StylesUpdate -> f StylesUpdate
forall a. a -> a
id