1{-# LANGUAGE NoImplicitPrelude          #-}
2
3module RIO.PrettyPrint.StylesUpdate
4  (
5    StylesUpdate (..)
6  , parseStylesUpdateFromString
7  , HasStylesUpdate (..)
8  ) where
9
10import Data.Aeson (FromJSON(..), withText)
11import Data.Array.IArray (assocs)
12import Data.Colour.SRGB (Colour, sRGB24)
13import Data.Text as T (pack, unpack)
14import RIO
15import RIO.PrettyPrint.DefaultStyles (defaultStyles)
16import RIO.PrettyPrint.Types (Style, StyleSpec)
17import System.Console.ANSI.Types (BlinkSpeed (..), Color (..),
18         ColorIntensity (..), ConsoleIntensity (..), ConsoleLayer (..),
19         SGR (..), Underlining (..))
20
21-- |Updates to 'Styles'
22newtype StylesUpdate = StylesUpdate { stylesUpdate :: [(Style, StyleSpec)] }
23  deriving (Eq, Show)
24
25-- |The first styles update overrides the second one.
26instance Semigroup StylesUpdate where
27  -- See module "Data.IArray.Array" of package @array@: this depends on GHC's
28  -- implementation of '(//)' being such that the last value specified for a
29  -- duplicated index is used.
30  StylesUpdate s1 <> StylesUpdate s2 = StylesUpdate (s2 <> s1)
31
32instance Monoid StylesUpdate where
33  mempty = StylesUpdate []
34  mappend = (<>) -- This needs to be specified as, before package
35                 -- @base-4.11.0.0@ (GHC 8.4.2, March 2018), the default is
36                 -- 'mappend = (++)'.
37
38instance FromJSON StylesUpdate where
39  parseJSON = withText "StylesUpdate" $
40    return . parseStylesUpdateFromString . T.unpack
41
42-- |Parse a string that is a colon-delimited sequence of key=value, where 'key'
43-- is a style name and 'value' is a semicolon-delimited list of 'ANSI' SGR
44-- (Select Graphic Rendition) control codes (in decimal). Keys that are not
45-- present in 'defaultStyles' are ignored. Items in the semicolon-delimited
46-- list that are not recognised as valid control codes are ignored.
47parseStylesUpdateFromString :: String -> StylesUpdate
48parseStylesUpdateFromString s = StylesUpdate $ mapMaybe process table
49 where
50  table = do
51    w <- split ':' s
52    let (k, v') = break (== '=') w
53    case v' of
54      '=' : v -> return (T.pack k, parseCodes v)
55      _ -> []
56
57  process :: StyleSpec -> Maybe (Style, StyleSpec)
58  process (k, sgrs) = do
59    style <- lookup k styles
60    return (style, (k, sgrs))
61
62styles :: [(Text, Style)]
63styles = map (\(s, (k, _)) -> (k, s)) $ assocs defaultStyles
64
65parseCodes :: String -> [SGR]
66parseCodes [] = []
67parseCodes s = parseCodes' c
68 where
69  s' = split ';' s
70  c :: [Word8]
71  c = mapMaybe readMaybe s'
72
73parseCodes' :: [Word8] -> [SGR]
74parseCodes' c = case codeToSGR c of
75  (Nothing, []) -> []
76  (Just sgr, []) -> [sgr]
77  (Nothing, cs) -> parseCodes' cs
78  (Just sgr, cs) -> sgr : parseCodes' cs
79
80split :: Char -> String -> [String]
81split c s = case rest of
82                []     -> [chunk]
83                _:rest1 -> chunk : split c rest1
84  where
85    (chunk, rest) = break (==c) s
86
87-- |This function is, essentially, the inverse of 'sgrToCode' exported by
88-- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The
89-- \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for
90-- Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T
91-- Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information
92-- Technology – Open Document Architecture (ODA) and Interchange Format:
93-- Character Content Architectures\` (also published as ISO/IEC International
94-- Standard 8613-6); and (3) further extensions used by \'XTerm\', a terminal
95-- emulator for the X Window System. The escape codes are described in a
96-- Wikipedia article at <http://en.wikipedia.org/wiki/ANSI_escape_code> and
97-- those codes supported on current versions of Windows at
98-- <https://docs.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences>.
99codeToSGR :: [Word8] -> (Maybe SGR, [Word8])
100codeToSGR [] = (Nothing, [])
101codeToSGR (c:cs)
102  | c ==  0 = (Just Reset, cs)
103  | c ==  1 = (Just $ SetConsoleIntensity BoldIntensity, cs)
104  | c ==  2 = (Just $ SetConsoleIntensity FaintIntensity, cs)
105  | c ==  3 = (Just $ SetItalicized True, cs)
106  | c ==  4 = (Just $ SetUnderlining SingleUnderline, cs)
107  | c ==  5 = (Just $ SetBlinkSpeed SlowBlink, cs)
108  | c ==  6 = (Just $ SetBlinkSpeed RapidBlink, cs)
109  | c ==  7 = (Just $ SetSwapForegroundBackground True, cs)
110  | c ==  8 = (Just $ SetVisible False, cs)
111  | c == 21 = (Just $ SetUnderlining DoubleUnderline, cs)
112  | c == 22 = (Just $ SetConsoleIntensity NormalIntensity, cs)
113  | c == 23 = (Just $ SetItalicized False, cs)
114  | c == 24 = (Just $ SetUnderlining NoUnderline, cs)
115  | c == 25 = (Just $ SetBlinkSpeed NoBlink, cs)
116  | c == 27 = (Just $ SetSwapForegroundBackground False, cs)
117  | c == 28 = (Just $ SetVisible True, cs)
118  | c >= 30 && c <= 37 =
119    (Just $ SetColor Foreground Dull $ codeToColor (c - 30), cs)
120  | c == 38 = case codeToRGB cs of
121    (Nothing, cs') -> (Nothing, cs')
122    (Just color, cs') -> (Just $ SetRGBColor Foreground color, cs')
123  | c >= 40 && c <= 47 =
124    (Just $ SetColor Background Dull $ codeToColor (c - 40), cs)
125  | c == 48 = case codeToRGB cs of
126    (Nothing, cs') -> (Nothing, cs')
127    (Just color, cs') -> (Just $ SetRGBColor Background color, cs')
128  | c >= 90 && c <= 97 =
129    (Just $ SetColor Foreground Vivid $ codeToColor (c - 90), cs)
130  | c >= 100 && c <= 107 =
131    (Just $ SetColor Background Vivid $ codeToColor (c - 100), cs)
132  | otherwise = (Nothing, cs)
133
134-- |This function is, essentially, the inverse of 'colorToCode' exported by
135-- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The
136-- \'ANSI\' standards refer to eight named colours in a specific order. The code
137-- is a 0-based index of those colours.
138codeToColor :: Word8 -> Color
139codeToColor c
140  -- 'toEnum' is not used because the @ansi-terminal@ package does not
141  -- /guarantee/ the order of the data constructors of type 'Color' will be the
142  -- same as that of the \'ANSI\' standards (although it currently is). (The
143  -- 'colorToCode' function itself does not use 'fromEnum'.)
144  | c == 0 = Black
145  | c == 1 = Red
146  | c == 2 = Green
147  | c == 3 = Yellow
148  | c == 4 = Blue
149  | c == 5 = Magenta
150  | c == 6 = Cyan
151  | c == 7 = White
152  | otherwise = error "Error: codeToColor, code outside 0 to 7."
153
154codeToRGB :: [Word8] -> (Maybe (Colour Float), [Word8])
155codeToRGB [] = (Nothing, [])
156codeToRGB (2:r:g:b:cs) = (Just $ sRGB24 r g b, cs)
157codeToRGB cs = (Nothing, cs)
158
159-- | Environment values with a styles update.
160--
161-- @since 0.1.0.0
162class HasStylesUpdate env where
163  stylesUpdateL :: Lens' env StylesUpdate
164instance HasStylesUpdate StylesUpdate where
165  stylesUpdateL = id
166