Colors, links, and strikeout

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.

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\\"

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

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