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.

Author: silby

src/Text/DocLayout.hs

@@ -70,6 +70,7 @@ module Text.DocLayout (
      , magenta
      , cyan
      , white
+     , link
      , empty
      -- * Functions for concatenating documents
      , (<+>)
@@ -149,6 +150,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)
@@ -261,6 +263,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
@@ -274,9 +277,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
                      }
@@ -287,9 +290,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 }
 
@@ -300,22 +303,25 @@ render :: HasChars a => Maybe Int -> Doc a -> a
 render = renderPlain
 
 renderANSI :: HasChars a => Maybe Int -> Doc a -> a
-renderANSI n d = snd $ go $ prerender n d where
-  go (Attributed s) = foldl attrRender (baseFont, "") s
+renderANSI n d = (\(_,_,o) -> o) $ go $ prerender n d where
+  go (Attributed s) = foldl attrRender (Nothing, baseFont, "") 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 => (Link, Font, a) -> Attr a -> (Link, Font, a)
+attrRender (l, f, acc) (Attr m g y)
+    | isNull y = (l, f, acc)
+    | otherwise = (m, g, acc <> newFont <> newLink <> y)
+  where
+    newLink = if l == m then mempty else renderOSC8 (fromString . T.unpack <$> m)
+    newFont = if f == g then mempty else renderFont g
 
-attrRender :: HasChars a => (Font, a) -> Attr a -> (Font, a)
-attrRender (f, acc) (Attr g y)
-  | isNull y = (f, acc)
-  | f == g = (f, acc <> y)
-  | otherwise = (g, acc <> renderFont g <> y)
 
 prerender :: HasChars a => Maybe Int -> Doc a -> Attributed a
 prerender linelen doc = fromList . reverse . output $
@@ -327,7 +333,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
@@ -390,7 +397,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
@@ -406,6 +413,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
@@ -474,7 +493,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)
@@ -519,6 +538,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
@@ -636,6 +656,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)
@@ -802,6 +823,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.

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

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

@@ -54,18 +54,18 @@ instance HasChars TL.Text where
   isNull            = TL.null
 
 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
+  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
 
 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