lipstick-0.1.0.0: src/Lipstick/Ansi.hs
{-# LANGUAGE OverloadedStrings #-}
-- | Serialising blocks to text with ANSI escape sequences, and parsing
-- such text back into styled 'Inline' text.
--
-- == Examples
--
-- A block as text with escape sequences, for a 'RenderEnv':
--
-- >>> let hi = render (bold <> fg "#F25D94") "hi"
-- >>> toAnsi defaultRenderEnv hi
-- "\ESC[0;1;38;2;242;93;148mhi\ESC[0m"
-- >>> toAnsi defaultRenderEnv {envProfile = ANSI256} hi
-- "\ESC[0;1;38;5;204mhi\ESC[0m"
-- >>> toAnsi defaultRenderEnv {envProfile = ANSI16} hi
-- "\ESC[0;1;35mhi\ESC[0m"
-- >>> toAnsi defaultRenderEnv {envProfile = NoTTY} hi
-- "hi"
--
-- Each line on its own, or without any escape sequences:
--
-- >>> toAnsiLines defaultRenderEnv (vcat [render (fg red) "hi", "there"])
-- ["\ESC[0;31mhi\ESC[0m ","there"]
-- >>> renderPlain (vcat [render (fg red) "hi", "there"])
-- "hi \nthere"
--
-- The 'envWidth' is the width blocks are laid out in:
--
-- >>> renderPlain (render (border asciiBorder <> fillWidth) "hi")
-- "+--+\n|hi|\n+--+"
-- >>> toAnsi defaultRenderEnv {envProfile = NoTTY, envWidth = Just 10} (render (border asciiBorder <> fillWidth) "hi")
-- "+--------+\n|hi |\n+--------+"
--
-- Text that already has escape sequences, such as another program's
-- output, becomes 'Inline' text with the same attributes:
--
-- >>> let report = fromAnsi "\ESC[1;32mok\ESC[0m 3 tests passed"
-- >>> putBlock (render (border roundedBorder <> padding 0 1) report)
-- ╭───────────────────╮
-- │ ok 3 tests passed │
-- ╰───────────────────╯
-- >>> toAnsi defaultRenderEnv (fromInline report)
-- "\ESC[0;1;32mok\ESC[0m 3 tests passed"
-- >>> ansiWidth "\ESC[1;32mok\ESC[0m 3 tests passed"
-- 17
module Lipstick.Ansi
( RenderEnv
, envProfile
, envDarkBackground
, envWidth
, defaultRenderEnv
, toAnsi
, toAnsiLines
, renderPlain
, escapeUri
, fromAnsi
, ansiWidth
, ansiHeight
) where
import Data.Array (Array, listArray, (!))
import Data.Char (isDigit)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word (Word8)
import Lipstick.Color
import Lipstick.Internal.Color (Color (..))
import Lipstick.Internal.Grid
import Lipstick.Internal.Layout (Block, layout)
import Lipstick.Internal.Types
-- $setup
-- >>> import Lipstick
-- | What the output can display, and the width to lay blocks out in.
-- Change 'defaultRenderEnv' with record update syntax.
data RenderEnv = RenderEnv
{ envProfile :: !ColorProfile
-- ^ the colours and attributes the output can display
, envDarkBackground :: !Bool
-- ^ whether 'lightDark' colours take their dark variant
, envWidth :: !(Maybe Int)
-- ^ the width blocks are laid out in; 'Nothing' for their natural width
}
deriving (Eq, Show)
-- | True colour on a dark background, blocks at their natural width.
defaultRenderEnv :: RenderEnv
defaultRenderEnv = RenderEnv TrueColor True Nothing
-- | 'toAnsiLines' joined with newlines, without a trailing newline.
toAnsi :: RenderEnv -> Block -> Text
toAnsi env = T.intercalate (T.singleton '\n') . toAnsiLines env
-- | The block laid out in the 'envWidth', one 'Text' per line. Every line
-- is the block's full width, padded with spaces, and stands alone:
-- attributes are reset and hyperlinks closed at its end.
toAnsiLines :: RenderEnv -> Block -> [Text]
toAnsiLines env = map (T.concat . renderLine env) . gridLines . layout (envWidth env)
-- | The block at its natural width, without any escape sequences.
renderPlain :: Block -> Text
renderPlain = toAnsi (RenderEnv NoTTY True Nothing)
-- | Fully resolved graphic rendition.
data SGR = SGR
{ sgrFg, sgrBg, sgrUl :: !(Maybe TermColor)
, sgrBold, sgrFaint, sgrItalic, sgrBlink, sgrReverse, sgrStrike :: !Bool
, sgrUnderline :: !Underline
}
deriving (Eq)
plainSGR :: SGR
plainSGR = SGR Nothing Nothing Nothing False False False False False False NoUnderline
resolveAttrs :: RenderEnv -> Attrs -> (SGR, Maybe Text)
resolveAttrs (RenderEnv NoTTY _ _) _ = (plainSGR, Nothing)
resolveAttrs (RenderEnv p dark _) a =
( SGR
{ sgrFg = col (attrFg a)
, sgrBg = col (attrBg a)
, sgrUl = if ul /= NoUnderline && p >= ANSI256 then col (attrUnderlineColor a) else Nothing
, sgrBold = on attrBold
, sgrFaint = on attrFaint
, sgrItalic = on attrItalic
, sgrBlink = on attrBlink
, sgrReverse = on attrReverse
, sgrStrike = on attrStrikethrough
, sgrUnderline = if ul /= NoUnderline && p < TrueColor then SingleUnderline else ul
}
, attrLink a
)
where
col c = c >>= resolveColor p dark
on f = fromMaybe False (f a)
ul = fromMaybe NoUnderline (attrUnderline a)
-- | The pieces of a line: cluster texts and escape sequences, to be joined
-- with one 'T.concat'. Attributes are resolved only where they change.
renderLine :: RenderEnv -> Line -> [Text]
renderLine env = go plainSGR Nothing Nothing . lineCells
where
go cur lnk _ [] =
[sgrCode plainSGR | cur /= plainSGR] ++ [closeLink | Just _ <- [lnk]]
go cur lnk prev (Cell a t _ _ : rest)
| Just a == prev = t : go cur lnk prev rest
| otherwise =
let (sgr, lnk') = resolveAttrs env a
linkB
| lnk' == lnk = []
| otherwise = [closeLink | Just _ <- [lnk]] ++ [openLink u | Just u <- [lnk']]
sgrB = [sgrCode sgr | sgr /= cur]
in linkB ++ sgrB ++ t : go sgr lnk' (Just a) rest
openLink :: Text -> Text
openLink url = T.concat ["\ESC]8;;", escapeUri url, "\ESC\\"]
closeLink :: Text
closeLink = "\ESC]8;;\ESC\\"
-- | A complete SGR sequence: reset, then every active attribute.
sgrCode :: SGR -> Text
sgrCode s = T.concat ["\ESC[", T.intercalate ";" ("0" : params), "m"]
where
params =
concat
[ ["1" | sgrBold s]
, ["2" | sgrFaint s]
, ["3" | sgrItalic s]
, underlineParams (sgrUnderline s)
, ["5" | sgrBlink s]
, ["7" | sgrReverse s]
, ["9" | sgrStrike s]
, maybe [] (colorParams 30 90 "38") (sgrFg s)
, maybe [] (colorParams 40 100 "48") (sgrBg s)
, maybe [] ulColorParams (sgrUl s)
]
underlineParams = \case
NoUnderline -> []
SingleUnderline -> ["4"]
DoubleUnderline -> ["4:2"]
CurlyUnderline -> ["4:3"]
DottedUnderline -> ["4:4"]
DashedUnderline -> ["4:5"]
colorParams :: Word8 -> Word8 -> Text -> TermColor -> [Text]
colorParams base brightBase ext = \case
TC16 n
| n < 8 -> [decimal (base + n)]
| otherwise -> [decimal (brightBase + n - 8)]
TC256 n -> [ext, "5", decimal n]
TCRGB r g b -> [ext, "2", decimal r, decimal g, decimal b]
ulColorParams = \case
TC16 n -> ["58", "5", decimal n]
TC256 n -> ["58", "5", decimal n]
TCRGB r g b -> ["58", "2", decimal r, decimal g, decimal b]
-- | A byte in decimal, from a table: SGR parameters are all bytes.
decimal :: Word8 -> Text
decimal = (numbers !)
where
numbers :: Array Word8 Text
numbers = listArray (0, 255) [T.pack (show i) | i <- [0 :: Int .. 255]]
-- Parsing ---------------------------------------------------------------------
-- | Parse text containing ANSI escape sequences, such as the output of
-- another program, into styled text.
--
-- SGR sequences (colours, attributes, underline styles and colours) and
-- OSC 8 hyperlinks are kept; every other escape sequence is dropped, along
-- with the payload of control strings (DCS, SOS, PM, APC: sixel and kitty
-- graphics, tmux passthrough).
-- Sequences that switch an attribute off (such as @22@ or @39@) unset it,
-- so the attributes of an enclosing style show through, and a reset
-- reveals the enclosing style completely but does not end a hyperlink,
-- which only OSC 8 does.
fromAnsi :: Text -> Inline
fromAnsi = Inline . go mempty
where
-- ESC, and the 8-bit forms of CSI, OSC and the control strings.
isEscape c = c == '\ESC' || c `elem` ['\x9B', '\x9D', '\x90', '\x98', '\x9E', '\x9F']
go a t =
let (txt, rest) = T.break isEscape t
in [(a, txt) | not (T.null txt)] ++ case T.uncons rest of
Nothing -> []
Just ('\x9B', r) -> csi a r
Just ('\x9D', r) -> osc a r
Just ('\ESC', r) -> case T.uncons r of
Just ('[', r') -> csi a r'
Just (']', r') -> osc a r'
Just (c, r')
-- DCS, SOS, PM, APC
| c `elem` ['P', 'X', '^', '_'] -> go a (controlString r')
-- ESC, intermediates, final (e.g. ESC ( B)
| c >= ' ' && c <= '/' -> go a (escFinal (T.dropWhile (\x -> x >= ' ' && x <= '/') r'))
| otherwise -> go a (escFinal r)
Nothing -> []
Just (_, r) -> go a (controlString r)
-- CSI: parameters, intermediates, final byte; anything else cuts it
-- short and is kept, as after ESC. Only a sequence with neither a
-- private marker (<=>?), as in xterm's CSI > 4 ; 2 m, nor
-- intermediates is SGR.
csi a r =
let (params, r1) = T.span (\c -> c >= '0' && c <= '?') r
(inter, r2) = T.span (\c -> c >= ' ' && c <= '/') r1
isSGR = T.all (\c -> c < '<') params && T.null inter
in case T.uncons r2 of
Just ('m', r3) | isSGR -> go (applySGR (sgrGroups params) a) r3
Just (c, r3) | c >= '@' && c <= '~' -> go a r3
_ -> go a r2
-- The final byte of an escape sequence. Anything else, such as a
-- newline or the ESC of another sequence, cuts the sequence short and
-- is kept.
escFinal r = case T.uncons r of
Just (c, r') | c >= '0' && c <= '~' -> r'
_ -> r
-- OSC: up to BEL or ST.
osc a r =
let (body, r1) = T.break endsString r
in go (applyOSC body a) (afterString r1)
-- A control string ends with ST (ESC \ or 0x9C) or BEL, or is cut
-- short by the ESC of another sequence.
endsString c = c == '\a' || c == '\ESC' || c == '\x9C'
-- The payload of DCS, SOS, PM or APC. tmux passthrough doubles every
-- ESC of the sequence it wraps, so ESC ESC does not end the string.
controlString r =
let r1 = T.dropWhile (not . endsString) r
in maybe (afterString r1) controlString (T.stripPrefix "\ESC\ESC" r1)
afterString r = case T.uncons r of
Just ('\ESC', x) -> fromMaybe r (T.stripPrefix (T.singleton '\\') x)
Just (_, x) -> x
Nothing -> T.empty
applyOSC body a = case T.splitOn ";" body of
"8" : _params : uri -> a {attrLink = if T.null (T.intercalate ";" uri) then Nothing else Just (T.intercalate ";" uri)}
_ -> a
-- | SGR parameters: groups separated by @;@, each with @:@ sub-parameters.
-- Missing numbers count as 0. Numbers too long to mean anything are kept
-- out of range rather than read modulo the size of 'Int'.
sgrGroups :: Text -> [[Int]]
sgrGroups params
| T.null params = [[0]]
| otherwise = map (map number . T.splitOn ":") (T.splitOn ";" params)
where
number t
| T.null t || not (T.all isDigit t) = 0
| T.length t > 6 = 1000000
| otherwise = read (T.unpack t)
applySGR :: [[Int]] -> Attrs -> Attrs
applySGR groups a = case groups of
[] -> a
grp : gs -> case grp of
-- A reset does not end a hyperlink: that is OSC 8, not SGR, state.
[0] -> applySGR gs mempty {attrLink = attrLink a}
[1] -> next a {attrBold = Just True}
[2] -> next a {attrFaint = Just True}
[3] -> next a {attrItalic = Just True}
[4] -> next a {attrUnderline = Just SingleUnderline}
[4, n] -> next a {attrUnderline = if n == 0 then Nothing else Just (underlineFrom n)}
[n] | n == 5 || n == 6 -> next a {attrBlink = Just True}
[7] -> next a {attrReverse = Just True}
[9] -> next a {attrStrikethrough = Just True}
[21] -> next a {attrUnderline = Just DoubleUnderline}
[22] -> next a {attrBold = Nothing, attrFaint = Nothing}
[23] -> next a {attrItalic = Nothing}
[24] -> next a {attrUnderline = Nothing}
[25] -> next a {attrBlink = Nothing}
[27] -> next a {attrReverse = Nothing}
[29] -> next a {attrStrikethrough = Nothing}
[n]
| n >= 30 && n <= 37 -> next a {attrFg = Just (Color16 (fromIntegral (n - 30)))}
| n >= 40 && n <= 47 -> next a {attrBg = Just (Color16 (fromIntegral (n - 40)))}
| n >= 90 && n <= 97 -> next a {attrFg = Just (Color16 (fromIntegral (n - 82)))}
| n >= 100 && n <= 107 -> next a {attrBg = Just (Color16 (fromIntegral (n - 92)))}
[39] -> next a {attrFg = Nothing}
[49] -> next a {attrBg = Nothing}
[59] -> next a {attrUnderlineColor = Nothing}
-- "38;5;n" and "38;2;r;g;b". A colour out of range is ignored; when
-- the colour is cut short, or of an unknown kind, the parameters left
-- are taken to be part of it and ignored too, rather than read as
-- attributes.
[n] | isColorParam n -> case gs of
[5] : [i] : rest -> applySGR rest (setColor n (palette i) a)
[2] : [r] : [g] : [b] : rest -> applySGR rest (setColor n (rgbOf r g b) a)
_ -> a
-- "38:5:n", "38:2:r:g:b" and "38:2:colourspace:r:g:b"
n : sub | isColorParam n -> next (setColor n (colon sub) a)
_ -> next a
where
next = applySGR gs
where
isColorParam n = n == 38 || n == 48 || n == 58
colon = \case
[5, i] -> palette i
[2, r, g, b] -> rgbOf r g b
2 : _ : r : g : b : _ -> rgbOf r g b
_ -> Nothing
byte i = if i >= 0 && i <= 255 then Just (fromIntegral i) else Nothing
palette i = Color256 <$> byte i
rgbOf r g b = RGB <$> byte r <*> byte g <*> byte b
-- Without a colour, the attributes are left as they were.
setColor n c x = case (n, c) of
(_, Nothing) -> x
(38, _) -> x {attrFg = c}
(48, _) -> x {attrBg = c}
_ -> x {attrUnderlineColor = c}
underlineFrom n = case n of
2 -> DoubleUnderline
3 -> CurlyUnderline
4 -> DottedUnderline
5 -> DashedUnderline
_ -> SingleUnderline
-- | The display width of text that may contain escape sequences: the width
-- of its widest line, with tabs as four columns.
ansiWidth :: Text -> Int
ansiWidth = gridWidth . fromCellLines . inlineLines 4 . fromAnsi
-- | The number of lines of text that may contain escape sequences: one
-- more than the number of newlines.
ansiHeight :: Text -> Int
ansiHeight = gridHeight . fromCellLines . inlineLines 4 . fromAnsi