diff --git a/src/Text/DocLayout.hs b/src/Text/DocLayout.hs index 8fa9f8c..1e42f17 100644 --- a/src/Text/DocLayout.hs +++ b/src/Text/DocLayout.hs @@ -59,6 +59,19 @@ module Text.DocLayout ( , bold , italic , underlined + , strikeout + , fg + , bg + , Color + , black + , red + , green + , yellow + , blue + , magenta + , cyan + , white + , link , empty -- * Functions for concatenating documents , (<+>) @@ -140,6 +153,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) @@ -252,6 +266,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 @@ -265,9 +280,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 } @@ -278,9 +293,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 } @@ -291,22 +306,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 @@ -319,7 +335,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 @@ -382,7 +399,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 @@ -398,6 +415,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 @@ -466,7 +495,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) @@ -511,6 +540,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 @@ -628,6 +658,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) @@ -757,6 +788,49 @@ 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 +-- 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 + +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..b952d0b 100644 --- a/src/Text/DocLayout/ANSIFont.hs +++ b/src/Text/DocLayout/ANSIFont.hs @@ -8,36 +8,47 @@ module Text.DocLayout.ANSIFont , Shape(..) , Color8(..) , Underline(..) + , Strikeout(..) , Foreground(..) , Background(..) , (~>) , renderFont + , renderOSC8 ) where import Data.Data (Data) import Data.String +import Data.Text (Text) data Font = Font { ftWeight :: Weight, ftShape :: Shape, ftUnderline :: Underline, + ftStrikeout :: Strikeout, 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 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 @@ -46,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" @@ -75,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" @@ -84,3 +100,8 @@ 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\\" +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