From 949d42ffcf5b96fef16b19b398a3e4aa50495ca2 Mon Sep 17 00:00:00 2001 From: Evan Silberman Date: Mon, 11 Mar 2024 15:34:13 -0700 Subject: [PATCH 1/3] Add initial external API for colored docs --- src/Text/DocLayout.hs | 48 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/src/Text/DocLayout.hs b/src/Text/DocLayout.hs index 8fa9f8c..d01e642 100644 --- a/src/Text/DocLayout.hs +++ b/src/Text/DocLayout.hs @@ -59,6 +59,17 @@ module Text.DocLayout ( , bold , italic , underlined + , fg + , bg + , Color + , black + , red + , green + , yellow + , blue + , magenta + , cyan + , white , empty -- * Functions for concatenating documents , (<+>) @@ -757,6 +768,43 @@ italic = styled (RShape Italic) underlined :: HasChars a => Doc a -> Doc a underlined = styled (RUnderline ULSingle) +-- The Color type is here as an opaque alias to Color8 for the public interface +-- and there's trivial smart constructors for the individual colors to +-- hopefully allow for easier extension to supporting indexed and rgb colors in +-- the future, without dramatically changing the public API. + +type Color = Color8 + +fg :: HasChars a => Color -> Doc a -> Doc a +fg = styled . RForeground . FG + +bg :: HasChars a => Color -> Doc a -> Doc a +bg = styled . RBackground . BG + +blue :: Color +blue = Blue + +black :: Color +black = Black + +red :: Color +red = Red + +green :: Color +green = Green + +yellow :: Color +yellow = Yellow + +magenta :: Color +magenta = Magenta + +cyan :: Color +cyan = Cyan + +white :: Color +white = White + -- | Returns width of a character in a monospace font: 0 for a combining -- character, 1 for a regular character, 2 for an East Asian wide character. -- Ambiguous characters are treated as width 1. From 16e923e2866c5de45b1df7e21a49902fc679c553 Mon Sep 17 00:00:00 2001 From: Evan Silberman Date: Tue, 12 Mar 2024 10:11:11 -0700 Subject: [PATCH 2/3] Introduce ANSI link support The `Attr` constructor grows a field for a link target, which is just a `Maybe Text` for the time being. We deem nested links to be illegal, like HTML, and so the rendering state only has to keep track of one link at a time. When rendering to ANSI, we use OSC8 to include the link in the output. OSC8 links support an "id" parameter which tells terminals to treat discontiguous linked text spans as being "the same" link, for mouseover purposes. Our code could grow to support this. --- src/Text/DocLayout.hs | 52 +++++++++++++++++++++++--------- src/Text/DocLayout/ANSIFont.hs | 11 +++++-- src/Text/DocLayout/Attributed.hs | 15 +++++---- src/Text/DocLayout/HasChars.hs | 12 ++++---- 4 files changed, 61 insertions(+), 29 deletions(-) diff --git a/src/Text/DocLayout.hs b/src/Text/DocLayout.hs index d01e642..8218939 100644 --- a/src/Text/DocLayout.hs +++ b/src/Text/DocLayout.hs @@ -70,6 +70,7 @@ module Text.DocLayout ( , magenta , cyan , white + , link , empty -- * Functions for concatenating documents , (<+>) @@ -151,6 +152,7 @@ data Doc a = Text Int a -- ^ Text with specified width. | BlankLines Int -- ^ Ensure a number of blank lines. | Concat (Doc a) (Doc a) -- ^ Two documents concatenated. | Styled StyleReq (Doc a) + | Linked Text (Doc a) -- ^ A hyperlink | Empty deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Data, Typeable, Generic) @@ -263,6 +265,7 @@ data RenderState a = RenderState{ , column :: Int , newlines :: Int -- ^ Number of preceding newlines , fontStack :: [Font] + , linkTarget :: Maybe Text -- ^ Current link target } peekFont :: RenderState a -> Font @@ -276,9 +279,9 @@ newline = do let rawpref = prefix st' when (column st' == 0 && usePrefix st' && not (T.null rawpref)) $ do let pref = fromString $ T.unpack $ T.dropWhileEnd isSpace rawpref - modify $ \st -> st{ output = Attr baseFont pref : output st + modify $ \st -> st{ output = Attr Nothing baseFont pref : output st , column = column st + realLength pref } - modify $ \st -> st { output = Attr baseFont "\n" : output st + modify $ \st -> st { output = Attr Nothing baseFont "\n" : output st , column = 0 , newlines = newlines st + 1 } @@ -289,9 +292,9 @@ outp off s = do -- offset >= 0 (0 might be combining char) let pref = if usePrefix st' then fromString $ T.unpack $ prefix st' else mempty let font = peekFont st' when (column st' == 0 && not (isNull pref && font == baseFont)) $ - modify $ \st -> st{ output = Attr baseFont pref : output st + modify $ \st -> st{ output = Attr Nothing baseFont pref : output st , column = column st + realLength pref } - modify $ \st -> st{ output = Attr font s : output st + modify $ \st -> st{ output = Attr (linkTarget st) font s : output st , column = column st + off , newlines = 0 } @@ -302,22 +305,23 @@ render :: HasChars a => Maybe Int -> Doc a -> a render = renderPlain renderANSI :: HasChars a => Maybe Int -> Doc a -> TL.Text -renderANSI n d = B.toLazyText $ snd $ go $ prerender n d where - go (Attributed s) = foldl attrRender (baseFont, B.fromText "") s +renderANSI n d = B.toLazyText $ (\(_,_,o) -> o) $ go $ prerender n d where + go (Attributed s) = foldl attrRender (Nothing, baseFont, B.fromText "") s renderPlain :: HasChars a => Maybe Int -> Doc a -> a renderPlain n d = go $ prerender n d where go (Attributed s) = foldMap attrStrip s attrStrip :: HasChars a => Attr a -> a -attrStrip (Attr _ y) | isNull y = "" - | otherwise = y +attrStrip (Attr _ _ y) | isNull y = "" + | otherwise = y -attrRender :: HasChars a => (Font, B.Builder) -> Attr a -> (Font, B.Builder) -attrRender (f, acc) (Attr g y) - | isNull y = (f, acc) - | otherwise = (g, acc <> B.fromText newFont <> build y) +attrRender :: HasChars a => (Link, Font, B.Builder) -> Attr a -> (Link, Font, B.Builder) +attrRender (l, f, acc) (Attr m g y) + | isNull y = (l, f, acc) + | otherwise = (m, g, acc <> B.fromText newFont <> B.fromText newLink <> build y) where + newLink = if l == m then mempty else renderOSC8 m newFont = if f == g then mempty else renderFont g prerender :: HasChars a => Maybe Int -> Doc a -> Attributed a @@ -330,7 +334,8 @@ prerender linelen doc = fromList . reverse . output $ , lineLength = linelen , column = 0 , newlines = 2 - , fontStack = [] } + , fontStack = [] + , linkTarget = Nothing } renderDoc :: HasChars a => Doc a -> DocState a renderDoc = renderList . normalize . unfoldD @@ -393,7 +398,7 @@ renderList (CookedText off s : xs) = do let pref = if usePrefix st' then fromString $ T.unpack $ prefix st' else mempty let elems (Attributed x) = reverse $ toList x when (column st' == 0 && not (isNull pref)) $ - modify $ \st -> st{ output = Attr baseFont pref : output st + modify $ \st -> st{ output = Attr Nothing baseFont pref : output st , column = column st + realLength pref } modify $ \st -> st{ output = elems s ++ output st , column = column st + off @@ -409,6 +414,18 @@ renderList (Styled style doc : xs) = do modify $ \s -> s{ fontStack = fontStack st, output = output s } renderList xs +-- Nested links are nonsensical, we only handle the outermost and +-- silently ignore any attempts to have a link inside a link +renderList (Linked target doc : xs) = do + st <- get + case linkTarget st of + Nothing -> do + modify $ \s -> s{linkTarget = Just target} + renderDoc doc + modify $ \s -> s{linkTarget = Nothing} + _ -> renderDoc doc + renderList xs + renderList (Prefixed pref d : xs) = do st <- get let oldPref = prefix st @@ -477,7 +494,7 @@ renderList (b : xs) | isBlock b = do heightOf _ = 1 let maxheight = maximum $ map heightOf (b:bs) let toBlockSpec (Block w ls) = (w, ls) - toBlockSpec (VFill w t) = (w, map (singleton . (Attr font)) (take maxheight $ repeat t)) + toBlockSpec (VFill w t) = (w, map (singleton . (Attr (linkTarget st) font)) (take maxheight $ repeat t)) toBlockSpec _ = (0, []) let (_, lns') = foldl (mergeBlocks maxheight) (toBlockSpec b) (map toBlockSpec bs) @@ -522,6 +539,7 @@ startsBlank (BlankLines _) = True startsBlank (Concat Empty y) = startsBlank y startsBlank (Concat x _) = startsBlank x startsBlank (Styled _ x) = startsBlank x +startsBlank (Linked _ x) = startsBlank x startsBlank Empty = True isBlock :: Doc a -> Bool @@ -639,6 +657,7 @@ getOffset breakWhen (!l, !c) x = CookedText n _ -> (l, c + n) Empty -> (l, c) Styled _ d -> getOffset breakWhen (l, c) d + Linked _ d -> getOffset breakWhen (l, c) d CarriageReturn -> (max l c, 0) NewLine -> (max l c, 0) BlankLines _ -> (max l c, 0) @@ -805,6 +824,9 @@ cyan = Cyan white :: Color white = White +link :: HasChars a => Text -> Doc a -> Doc a +link = Linked + -- | Returns width of a character in a monospace font: 0 for a combining -- character, 1 for a regular character, 2 for an East Asian wide character. -- Ambiguous characters are treated as width 1. diff --git a/src/Text/DocLayout/ANSIFont.hs b/src/Text/DocLayout/ANSIFont.hs index c679427..a255a04 100644 --- a/src/Text/DocLayout/ANSIFont.hs +++ b/src/Text/DocLayout/ANSIFont.hs @@ -12,22 +12,25 @@ module Text.DocLayout.ANSIFont , Background(..) , (~>) , renderFont + , renderOSC8 ) where import Data.Data (Data) import Data.String +import Data.Text (Text) data Font = Font { ftWeight :: Weight, ftShape :: Shape, ftUnderline :: Underline, ftForeground :: Foreground, - ftBackground :: Background + ftBackground :: Background, + ftLink :: Maybe Text } deriving (Show, Eq, Read, Data, Ord) baseFont :: Font -baseFont = Font Normal Roman ULNone FGDefault BGDefault +baseFont = Font Normal Roman ULNone FGDefault BGDefault Nothing data Weight = Normal | Bold deriving (Show, Eq, Read, Data, Ord) data Shape = Roman | Italic deriving (Show, Eq, Read, Data, Ord) @@ -84,3 +87,7 @@ renderFont f <> renderSGR (ftForeground f) <> renderSGR (ftBackground f) <> renderSGR (ftUnderline f) + +renderOSC8 :: (Semigroup a, IsString a) => Maybe a -> a +renderOSC8 Nothing = "\ESC]8;;\ESC\\" +renderOSC8 (Just t) = "\ESC]8;;" <> t <> "\ESC\\" diff --git a/src/Text/DocLayout/Attributed.hs b/src/Text/DocLayout/Attributed.hs index 547446b..6b30123 100644 --- a/src/Text/DocLayout/Attributed.hs +++ b/src/Text/DocLayout/Attributed.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} -module Text.DocLayout.Attributed (Attributed(..), Attr(..), fromList, singleton) +module Text.DocLayout.Attributed (Attributed(..), Attr(..), Link, fromList, singleton) where import Data.String @@ -11,16 +11,19 @@ import Data.Data (Data, Typeable) import GHC.Generics import Data.Sequence ((><)) import qualified Data.Sequence as S +import Data.Text (Text) -data Attr a = Attr Font a +type Link = Maybe Text + +data Attr a = Attr Link Font a deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Data, Typeable, Generic) instance Semigroup a => Semigroup (Attr a) where - (<>) (Attr f x) (Attr _ y) = Attr f $ x <> y -- This is arbitrary + (<>) (Attr l f x) (Attr _ _ y) = Attr l f $ x <> y -- This is arbitrary instance (IsString a, Monoid a) => Monoid (Attr a) where - mempty = Attr baseFont (fromString "") + mempty = Attr Nothing baseFont (fromString "") newtype Attributed a = Attributed (S.Seq (Attr a)) deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, @@ -33,10 +36,10 @@ singleton :: Attr a -> Attributed a singleton = Attributed . S.singleton instance IsString a => IsString (Attr a) where - fromString x = Attr baseFont (fromString x) + fromString x = Attr Nothing baseFont (fromString x) instance IsString a => IsString (Attributed a) where - fromString x = Attributed $ S.singleton $ Attr baseFont (fromString x) + fromString x = Attributed $ S.singleton $ Attr Nothing baseFont (fromString x) instance Semigroup a => Semigroup (Attributed a) where (<>) (Attributed a) (Attributed b) = Attributed $ a >< b diff --git a/src/Text/DocLayout/HasChars.hs b/src/Text/DocLayout/HasChars.hs index 1605c9e..f059562 100644 --- a/src/Text/DocLayout/HasChars.hs +++ b/src/Text/DocLayout/HasChars.hs @@ -60,19 +60,19 @@ instance HasChars TL.Text where build = B.fromLazyText instance HasChars a => HasChars (Attr a) where - foldrChar f a (Attr _ x) = foldrChar f a x - foldlChar f a (Attr _ x) = foldlChar f a x - splitLines (Attr f x) = Attr f <$> splitLines x - build (Attr _ x) = build x + foldrChar f a (Attr _ _ x) = foldrChar f a x + foldlChar f a (Attr _ _ x) = foldlChar f a x + splitLines (Attr l f x) = Attr l f <$> splitLines x + build (Attr _ _ x) = build x instance (HasChars a) => HasChars (Attributed a) where foldrChar _ acc (Attributed S.Empty) = acc - foldrChar f acc (Attributed (xs :|> (Attr _ x))) = + foldrChar f acc (Attributed (xs :|> (Attr _ _ x))) = let l = foldrChar f acc x innerFold e a = foldrChar f a e in foldr innerFold l xs foldlChar _ acc (Attributed S.Empty) = acc - foldlChar f acc (Attributed ((Attr _ x) :<| xs)) = + foldlChar f acc (Attributed ((Attr _ _ x) :<| xs)) = let l = foldlChar f acc x innerFold e a = foldlChar f a e in foldr innerFold l xs From e6b6761ca50487d2d641cbe430b3c83f3157a693 Mon Sep 17 00:00:00 2001 From: Evan Silberman Date: Tue, 12 Mar 2024 11:00:55 -0700 Subject: [PATCH 3/3] Add strikeout support --- src/Text/DocLayout.hs | 4 ++++ src/Text/DocLayout/ANSIFont.hs | 20 +++++++++++++++++--- 2 files changed, 21 insertions(+), 3 deletions(-) diff --git a/src/Text/DocLayout.hs b/src/Text/DocLayout.hs index 8218939..1e42f17 100644 --- a/src/Text/DocLayout.hs +++ b/src/Text/DocLayout.hs @@ -59,6 +59,7 @@ module Text.DocLayout ( , bold , italic , underlined + , strikeout , fg , bg , Color @@ -787,6 +788,9 @@ italic = styled (RShape Italic) underlined :: HasChars a => Doc a -> Doc a underlined = styled (RUnderline ULSingle) +strikeout :: HasChars a => Doc a -> Doc a +strikeout = styled (RStrikeout Struck) + -- The Color type is here as an opaque alias to Color8 for the public interface -- and there's trivial smart constructors for the individual colors to -- hopefully allow for easier extension to supporting indexed and rgb colors in diff --git a/src/Text/DocLayout/ANSIFont.hs b/src/Text/DocLayout/ANSIFont.hs index a255a04..b952d0b 100644 --- a/src/Text/DocLayout/ANSIFont.hs +++ b/src/Text/DocLayout/ANSIFont.hs @@ -8,6 +8,7 @@ module Text.DocLayout.ANSIFont , Shape(..) , Color8(..) , Underline(..) + , Strikeout(..) , Foreground(..) , Background(..) , (~>) @@ -23,6 +24,7 @@ data Font = Font { ftWeight :: Weight, ftShape :: Shape, ftUnderline :: Underline, + ftStrikeout :: Strikeout, ftForeground :: Foreground, ftBackground :: Background, ftLink :: Maybe Text @@ -30,17 +32,23 @@ data Font = Font deriving (Show, Eq, Read, Data, Ord) baseFont :: Font -baseFont = Font Normal Roman ULNone FGDefault BGDefault Nothing +baseFont = Font Normal Roman ULNone Unstruck FGDefault BGDefault Nothing data Weight = Normal | Bold deriving (Show, Eq, Read, Data, Ord) data Shape = Roman | Italic deriving (Show, Eq, Read, Data, Ord) data Color8 = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White deriving (Show, Eq, Enum, Read, Data, Ord) data Underline = ULNone | ULSingle | ULDouble | ULCurly deriving (Show, Eq, Read, Data, Ord) +data Strikeout = Unstruck | Struck deriving (Show, Eq, Read, Data, Ord) data Foreground = FGDefault | FG Color8 deriving (Show, Eq, Read, Data, Ord) data Background = BGDefault | BG Color8 deriving (Show, Eq, Read, Data, Ord) -data StyleReq = - RWeight Weight | RShape Shape | RForeground Foreground | RBackground Background | RUnderline Underline +data StyleReq + = RWeight Weight + | RShape Shape + | RForeground Foreground + | RBackground Background + | RUnderline Underline + | RStrikeout Strikeout deriving (Show, Eq, Read, Data, Ord) (~>) :: Font -> StyleReq -> Font @@ -49,6 +57,7 @@ data StyleReq = (~>) f (RForeground c) = f{ftForeground = c} (~>) f (RBackground c) = f{ftBackground = c} (~>) f (RUnderline u) = f{ftUnderline = u} +(~>) f (RStrikeout u) = f{ftStrikeout = u} rawSGR :: (Semigroup a, IsString a) => a -> a rawSGR n = "\ESC[" <> n <> "m" @@ -78,6 +87,10 @@ instance SGR Underline where renderSGR ULDouble = rawSGR "21" renderSGR ULCurly = rawSGR "4:3" +instance SGR Strikeout where + renderSGR Unstruck = rawSGR "29" + renderSGR Struck = rawSGR "9" + renderFont :: (Semigroup a, IsString a) => Font -> a renderFont f | f == baseFont = rawSGR "0" @@ -87,6 +100,7 @@ renderFont f <> renderSGR (ftForeground f) <> renderSGR (ftBackground f) <> renderSGR (ftUnderline f) + <> renderSGR (ftStrikeout f) renderOSC8 :: (Semigroup a, IsString a) => Maybe a -> a renderOSC8 Nothing = "\ESC]8;;\ESC\\"