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