Add an experimental Attr for hyperlink escape sequences

This right now isn't (as far as I have seen) encoded in Terminfo,
which means that unfortunately we can't rely on the typical Terminfo
parser infrastructure. Right now, this is just written inline in the
TerminfoBased module, but maybe should be embedded elsewhere.

src/Graphics/Vty/Attributes.hs

@@ -50,6 +50,9 @@ module Graphics.Vty.Attributes
   , withForeColor
   , withBackColor
 
+  -- * Setting hyperlinks
+  , withURL
+
   -- * Colors
   , module Graphics.Vty.Attributes.Color
   , module Graphics.Vty.Attributes.Color240
@@ -57,6 +60,7 @@ module Graphics.Vty.Attributes
 where
 
 import Data.Bits
+import Data.Text (Text)
 import Data.Word
 
 import Graphics.Vty.Attributes.Color
@@ -73,6 +77,7 @@ data Attr = Attr
     { attrStyle :: !(MaybeDefault Style)
     , attrForeColor :: !(MaybeDefault Color)
     , attrBackColor :: !(MaybeDefault Color)
+    , attrURL :: !(MaybeDefault Text)
     } deriving ( Eq, Show, Read )
 
 -- This could be encoded into a single 32 bit word. The 32 bit word is
@@ -107,11 +112,12 @@ data Attr = Attr
 --  Then the background color encoded into 8 bits.
 
 instance Monoid Attr where
-    mempty = Attr mempty mempty mempty
+    mempty = Attr mempty mempty mempty mempty
     mappend attr0 attr1 =
         Attr ( attrStyle attr0     `mappend` attrStyle attr1 )
              ( attrForeColor attr0 `mappend` attrForeColor attr1 )
              ( attrBackColor attr0 `mappend` attrBackColor attr1 )
+             ( attrURL attr0       `mappend` attrURL attr1 )
 
 -- | Specifies the display attributes such that the final style and
 -- color values do not depend on the previously applied display
@@ -121,6 +127,7 @@ data FixedAttr = FixedAttr
     { fixedStyle :: !Style
     , fixedForeColor :: !(Maybe Color)
     , fixedBackColor :: !(Maybe Color)
+    , fixedURL       :: !(Maybe Text)
     } deriving ( Eq, Show )
 
 -- | The style and color attributes can either be the terminal defaults.
@@ -203,11 +210,15 @@ withStyle :: Attr -> Style -> Attr
 withStyle attr 0 = attr
 withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }
 
+-- | Add a hyperlinked URL
+withURL :: Attr -> Text -> Attr
+withURL attr url = attr { attrURL = SetTo url }
+
 -- | Sets the style, background color and foreground color to the
 -- default values for the terminal. There is no easy way to determine
 -- what the default background and foreground colors are.
 defAttr :: Attr
-defAttr = Attr Default Default Default
+defAttr = Attr Default Default Default Default
 
 -- | Keeps the style, background color and foreground color that was
 -- previously set. Used to override some part of the previous style.
@@ -217,4 +228,4 @@ defAttr = Attr Default Default Default
 -- Would be the currently applied style (be it underline, bold, etc) but
 -- with the foreground color set to brightMagenta.
 currentAttr :: Attr
-currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent
+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent

src/Graphics/Vty/DisplayAttributes.hs

@@ -6,6 +6,9 @@ module Graphics.Vty.DisplayAttributes where
 import Graphics.Vty.Attributes
 
 import Data.Bits ((.&.))
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
 
 -- | Given the previously applied display attributes as a FixedAttr and
 -- the current display attributes as an Attr produces a FixedAttr that
@@ -17,6 +20,7 @@ fixDisplayAttr fattr attr
     = FixedAttr (fixStyle (fixedStyle fattr)     (attrStyle attr))
                 (fixColor (fixedForeColor fattr) (attrForeColor attr))
                 (fixColor (fixedBackColor fattr) (attrBackColor attr))
+                (fixURL   (fixedURL fattr)       (attrURL attr))
     where
         fixStyle _s Default           = defaultStyleMask
         fixStyle s KeepCurrent        = s
@@ -24,6 +28,9 @@ fixDisplayAttr fattr attr
         fixColor _c Default           = Nothing
         fixColor c KeepCurrent        = c
         fixColor _c (SetTo c)         = Just c
+        fixURL c KeepCurrent          = c
+        fixURL _c (SetTo n)           = Just n
+        fixURL _c Default             = Nothing
 
 -- | difference between two display attributes. Used in the calculation
 -- of the operations required to go from one display attribute to the
@@ -36,16 +43,18 @@ data DisplayAttrDiff = DisplayAttrDiff
     { styleDiffs    :: [StyleStateChange]
     , foreColorDiff :: DisplayColorDiff
     , backColorDiff :: DisplayColorDiff
+    , urlDiff       :: URLDiff
     }
     deriving (Show)
 
 instance Monoid DisplayAttrDiff where
-    mempty = DisplayAttrDiff [] NoColorChange NoColorChange
+    mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange
     mappend d0 d1 =
         let ds  = simplifyStyleDiffs (styleDiffs d0)    (styleDiffs d1)
             fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
             bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
-        in DisplayAttrDiff ds fcd bcd
+            ud  = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
+        in DisplayAttrDiff ds fcd bcd ud
 
 -- | Used in the computation of a final style attribute change.
 simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
@@ -58,6 +67,12 @@ simplifyColorDiffs _cd             ColorToDefault = ColorToDefault
 simplifyColorDiffs cd              NoColorChange  = cd
 simplifyColorDiffs _cd             (SetColor !c)  = SetColor c
 
+-- | Consider two URL changes, which are mostly going to be the latter
+-- unless the latter specifies no change.
+simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff
+simplifyUrlDiffs ud NoLinkChange = ud
+simplifyUrlDiffs _ ud = ud
+
 -- | Difference between two display color attribute changes.
 data DisplayColorDiff
     = ColorToDefault
@@ -82,6 +97,13 @@ data StyleStateChange
     | RemoveBold
     deriving (Show, Eq)
 
+-- Setting and unsetting hyperlinks
+data URLDiff
+    = LinkTo !ByteString
+    | NoLinkChange
+    | EndLink
+    deriving (Show, Eq)
+
 -- | Determines the diff between two display&color attributes. This diff
 -- determines the operations that actually get output to the terminal.
 displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
@@ -89,8 +111,14 @@ displayAttrDiffs attr attr' = DisplayAttrDiff
     { styleDiffs    = diffStyles (fixedStyle attr)      (fixedStyle attr')
     , foreColorDiff = diffColor  (fixedForeColor attr) (fixedForeColor attr')
     , backColorDiff = diffColor  (fixedBackColor attr) (fixedBackColor attr')
+    , urlDiff       = diffURL    (fixedURL attr)       (fixedURL attr')
     }
 
+diffURL :: Maybe Text -> Maybe Text -> URLDiff
+diffURL Nothing Nothing = NoLinkChange
+diffURL (Just _) Nothing = EndLink
+diffURL _ (Just url) = LinkTo (encodeUtf8 url)
+
 diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
 diffColor Nothing  (Just c') = SetColor c'
 diffColor (Just c) (Just c')

src/Graphics/Vty/Inline.hs

@@ -94,7 +94,7 @@ putAttrChange out c = liftIO $ do
     fattr <- case mfattr of
                 Nothing -> do
                     liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc
-                    return $ FixedAttr defaultStyleMask Nothing Nothing
+                    return $ FixedAttr defaultStyleMask Nothing Nothing Nothing
                 Just v -> return v
     let attr = execState c currentAttr
         attr' = limitAttrForDisplay out attr

src/Graphics/Vty/Output/Interface.hs

@@ -163,7 +163,7 @@ outputPicture dc pic = liftIO $ do
     let manipCursor = supportsCursorVisibility (contextDevice dc)
         r = contextRegion dc
         ops = displayOpsForPic pic r
-        initialAttr = FixedAttr defaultStyleMask Nothing Nothing
+        initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing
         -- Diff the previous output against the requested output.
         -- Differences are currently on a per-row basis.
         diffs :: [Bool] = case prevOutputOps as of

src/Graphics/Vty/Output/TerminfoBased.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
 {-# CFILES gwinsz.c #-}
 
@@ -12,6 +13,7 @@ module Graphics.Vty.Output.TerminfoBased
 where
 
 import Control.Monad (when)
+import qualified Data.ByteString as BS
 import Data.ByteString.Internal (toForeignPtr)
 import Data.Terminfo.Parse
 import Data.Terminfo.Eval
@@ -21,11 +23,12 @@ import Graphics.Vty.Image (DisplayRegion)
 import Graphics.Vty.DisplayAttributes
 import Graphics.Vty.Output.Interface
 
-import Blaze.ByteString.Builder (Write, writeToByteString)
+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable)
 
 import Control.Monad.Trans
 
 import Data.Bits ((.&.))
+import Data.Foldable (foldMap)
 import Data.IORef
 import Data.Maybe (isJust, isNothing, fromJust)
 import Data.Word
@@ -237,6 +240,20 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
             , inlineHack = return ()
             }
 
+-- | Write the escape sequences that are used in some terminals to
+-- include embedded hyperlinks. As of yet, this information isn't
+-- included in termcap or terminfo, so this writes them directly
+-- instead of looking up the appropriate capabilities.
+writeURLEscapes :: URLDiff -> Write
+writeURLEscapes (LinkTo url) =
+    foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend`
+    foldMap writeStorable (BS.unpack url) `mappend`
+    writeStorable (0x07 :: Word8)
+writeURLEscapes EndLink =
+    foldMap writeStorable (BS.unpack "\x1b]8;;\a")
+writeURLEscapes NoLinkChange =
+    mempty
+
 -- | Portably setting the display attributes is a giant pain in the ass.
 --
 -- If the terminal supports the sgr capability (which sets the on/off
@@ -275,7 +292,7 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
 -- bytes.
 terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
 terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
-    case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
+    urlAttrs `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
         -- The only way to reset either color, portably, to the default
         -- is to use either the set state capability or the set default
         -- capability.
@@ -324,6 +341,7 @@ terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
                                                (sgrArgsForState state)
                                   `mappend` setColors
     where
+        urlAttrs = writeURLEscapes (urlDiff diffs)
         colorMap = case useAltColorMap terminfoCaps of
                         False -> ansiColorIndex
                         True -> altColorIndex