d8c18bb · vty · git.iko.soy

git.iko.soy/vty

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.

commitd8c18bb38f2b322e5661765c7b88f5f531e552fa authorGetty Ritter <gdritter@galois.com> dateFri 6 Oct 2017, 11:59 (9 years ago) parent452ed52

5 files changed+66−9

compare with master

unifiedsplit

src/Graphics/Vty/Attributes.hs+14−3 src/Graphics/Vty/DisplayAttributes.hs+30−2 src/Graphics/Vty/Inline.hs+1−1 src/Graphics/Vty/Output/Interface.hs+1−1 src/Graphics/Vty/Output/TerminfoBased.hs+20−2

src/Graphics/Vty/Attributes.hs+14−3

@@ -50,6 +50,9 @@ module Graphics.Vty.Attributes

5050 , withForeColor

5151 , withBackColor

5252

53+ -- * Setting hyperlinks

54+ , withURL

55+

5356 -- * Colors

5457 , module Graphics.Vty.Attributes.Color

5558 , module Graphics.Vty.Attributes.Color240

@@ -57,6 +60,7 @@ module Graphics.Vty.Attributes

5760where

5861

5962import Data.Bits

63+import Data.Text (Text)

6064import Data.Word

6165

6266import Graphics.Vty.Attributes.Color

@@ -73,6 +77,7 @@ data Attr = Attr

7377 { attrStyle :: !(MaybeDefault Style)

7478 , attrForeColor :: !(MaybeDefault Color)

7579 , attrBackColor :: !(MaybeDefault Color)

80+ , attrURL :: !(MaybeDefault Text)

7681 } deriving ( Eq, Show, Read )

7782

7883-- This could be encoded into a single 32 bit word. The 32 bit word is

@@ -107,11 +112,12 @@ data Attr = Attr

107112-- Then the background color encoded into 8 bits.

108113

109114instance Monoid Attr where

110− mempty = Attr mempty mempty mempty

115+ mempty = Attr mempty mempty mempty mempty

111116 mappend attr0 attr1 =

112117 Attr ( attrStyle attr0 `mappend` attrStyle attr1 )

113118 ( attrForeColor attr0 `mappend` attrForeColor attr1 )

114119 ( attrBackColor attr0 `mappend` attrBackColor attr1 )

120+ ( attrURL attr0 `mappend` attrURL attr1 )

115121

116122-- | Specifies the display attributes such that the final style and

117123-- color values do not depend on the previously applied display

@@ -121,6 +127,7 @@ data FixedAttr = FixedAttr

121127 { fixedStyle :: !Style

122128 , fixedForeColor :: !(Maybe Color)

123129 , fixedBackColor :: !(Maybe Color)

130+ , fixedURL :: !(Maybe Text)

124131 } deriving ( Eq, Show )

125132

126133-- | The style and color attributes can either be the terminal defaults.

@@ -203,11 +210,15 @@ withStyle :: Attr -> Style -> Attr

203210withStyle attr 0 = attr

204211withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }

205212

213+-- | Add a hyperlinked URL

214+withURL :: Attr -> Text -> Attr

215+withURL attr url = attr { attrURL = SetTo url }

216+

206217-- | Sets the style, background color and foreground color to the

207218-- default values for the terminal. There is no easy way to determine

208219-- what the default background and foreground colors are.

209220defAttr :: Attr

210−defAttr = Attr Default Default Default

221+defAttr = Attr Default Default Default Default

211222

212223-- | Keeps the style, background color and foreground color that was

213224-- previously set. Used to override some part of the previous style.

@@ -217,4 +228,4 @@ defAttr = Attr Default Default Default

217228-- Would be the currently applied style (be it underline, bold, etc) but

218229-- with the foreground color set to brightMagenta.

219230currentAttr :: Attr

220−currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent

231+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent

src/Graphics/Vty/DisplayAttributes.hs+30−2

@@ -6,6 +6,9 @@ module Graphics.Vty.DisplayAttributes where

66import Graphics.Vty.Attributes

88import Data.Bits ((.&.))

9+import Data.ByteString (ByteString)

10+import Data.Text (Text)

11+import Data.Text.Encoding (encodeUtf8)

912

1013-- | Given the previously applied display attributes as a FixedAttr and

1114-- the current display attributes as an Attr produces a FixedAttr that

@@ -17,6 +20,7 @@ fixDisplayAttr fattr attr

1720 = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))

1821 (fixColor (fixedForeColor fattr) (attrForeColor attr))

1922 (fixColor (fixedBackColor fattr) (attrBackColor attr))

23+ (fixURL (fixedURL fattr) (attrURL attr))

2024 where

2125 fixStyle _s Default = defaultStyleMask

2226 fixStyle s KeepCurrent = s

@@ -24,6 +28,9 @@ fixDisplayAttr fattr attr

2428 fixColor _c Default = Nothing

2529 fixColor c KeepCurrent = c

2630 fixColor _c (SetTo c) = Just c

31+ fixURL c KeepCurrent = c

32+ fixURL _c (SetTo n) = Just n

33+ fixURL _c Default = Nothing

2734

2835-- | difference between two display attributes. Used in the calculation

2936-- of the operations required to go from one display attribute to the

@@ -36,16 +43,18 @@ data DisplayAttrDiff = DisplayAttrDiff

3643 { styleDiffs :: [StyleStateChange]

3744 , foreColorDiff :: DisplayColorDiff

3845 , backColorDiff :: DisplayColorDiff

46+ , urlDiff :: URLDiff

3947 }

4048 deriving (Show)

4149

4250instance Monoid DisplayAttrDiff where

43− mempty = DisplayAttrDiff [] NoColorChange NoColorChange

51+ mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange

4452 mappend d0 d1 =

4553 let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)

4654 fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)

4755 bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)

48− in DisplayAttrDiff ds fcd bcd

56+ ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)

57+ in DisplayAttrDiff ds fcd bcd ud

4958

5059-- | Used in the computation of a final style attribute change.

5160simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]

@@ -58,6 +67,12 @@ simplifyColorDiffs _cd ColorToDefault = ColorToDefault

5867simplifyColorDiffs cd NoColorChange = cd

5968simplifyColorDiffs _cd (SetColor !c) = SetColor c

6069

70+-- | Consider two URL changes, which are mostly going to be the latter

71+-- unless the latter specifies no change.

72+simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff

73+simplifyUrlDiffs ud NoLinkChange = ud

74+simplifyUrlDiffs _ ud = ud

75+

6176-- | Difference between two display color attribute changes.

6277data DisplayColorDiff

6378 = ColorToDefault

@@ -82,6 +97,13 @@ data StyleStateChange

8297 | RemoveBold

8398 deriving (Show, Eq)

8499

100+-- Setting and unsetting hyperlinks

101+data URLDiff

102+ = LinkTo !ByteString

103+ | NoLinkChange

104+ | EndLink

105+ deriving (Show, Eq)

106+

85107-- | Determines the diff between two display&color attributes. This diff

86108-- determines the operations that actually get output to the terminal.

87109displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff

@@ -89,8 +111,14 @@ displayAttrDiffs attr attr' = DisplayAttrDiff

89111 { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')

90112 , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')

91113 , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')

114+ , urlDiff = diffURL (fixedURL attr) (fixedURL attr')

92115 }

93116

117+diffURL :: Maybe Text -> Maybe Text -> URLDiff

118+diffURL Nothing Nothing = NoLinkChange

119+diffURL (Just _) Nothing = EndLink

120+diffURL _ (Just url) = LinkTo (encodeUtf8 url)

121+

94122diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff

95123diffColor Nothing (Just c') = SetColor c'

96124diffColor (Just c) (Just c')

src/Graphics/Vty/Inline.hs+1−1

@@ -94,7 +94,7 @@ putAttrChange out c = liftIO $ do

9494 fattr <- case mfattr of

9595 Nothing -> do

9696 liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc

97− return $ FixedAttr defaultStyleMask Nothing Nothing

97+ return $ FixedAttr defaultStyleMask Nothing Nothing Nothing

9898 Just v -> return v

9999 let attr = execState c currentAttr

100100 attr' = limitAttrForDisplay out attr

src/Graphics/Vty/Output/Interface.hs+1−1

@@ -163,7 +163,7 @@ outputPicture dc pic = liftIO $ do

163163 let manipCursor = supportsCursorVisibility (contextDevice dc)

164164 r = contextRegion dc

165165 ops = displayOpsForPic pic r

166− initialAttr = FixedAttr defaultStyleMask Nothing Nothing

166+ initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing

167167 -- Diff the previous output against the requested output.

168168 -- Differences are currently on a per-row basis.

169169 diffs :: [Bool] = case prevOutputOps as of

src/Graphics/Vty/Output/TerminfoBased.hs+20−2

@@ -1,5 +1,6 @@

11{-# LANGUAGE RecordWildCards #-}

22{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE OverloadedStrings #-}

34{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}

45{-# CFILES gwinsz.c #-}

@@ -12,6 +13,7 @@ module Graphics.Vty.Output.TerminfoBased

1213where

1314

1415import Control.Monad (when)

16+import qualified Data.ByteString as BS

1517import Data.ByteString.Internal (toForeignPtr)

1618import Data.Terminfo.Parse

1719import Data.Terminfo.Eval

@@ -21,11 +23,12 @@ import Graphics.Vty.Image (DisplayRegion)

2123import Graphics.Vty.DisplayAttributes

2224import Graphics.Vty.Output.Interface

2325

24−import Blaze.ByteString.Builder (Write, writeToByteString)

26+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable)

2527

2628import Control.Monad.Trans

2729

2830import Data.Bits ((.&.))

31+import Data.Foldable (foldMap)

2932import Data.IORef

3033import Data.Maybe (isJust, isNothing, fromJust)

3134import Data.Word

@@ -237,6 +240,20 @@ terminfoDisplayContext tActual terminfoCaps r = return dc

237240 , inlineHack = return ()

238241 }

239242

243+-- | Write the escape sequences that are used in some terminals to

244+-- include embedded hyperlinks. As of yet, this information isn't

245+-- included in termcap or terminfo, so this writes them directly

246+-- instead of looking up the appropriate capabilities.

247+writeURLEscapes :: URLDiff -> Write

248+writeURLEscapes (LinkTo url) =

249+ foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend`

250+ foldMap writeStorable (BS.unpack url) `mappend`

251+ writeStorable (0x07 :: Word8)

252+writeURLEscapes EndLink =

253+ foldMap writeStorable (BS.unpack "\x1b]8;;\a")

254+writeURLEscapes NoLinkChange =

255+ mempty

256+

240257-- | Portably setting the display attributes is a giant pain in the ass.

241258--

242259-- If the terminal supports the sgr capability (which sets the on/off

@@ -275,7 +292,7 @@ terminfoDisplayContext tActual terminfoCaps r = return dc

275292-- bytes.

276293terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write

277294terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do

278− case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of

295+ urlAttrs `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of

279296 -- The only way to reset either color, portably, to the default

280297 -- is to use either the set state capability or the set default

281298 -- capability.

@@ -324,6 +341,7 @@ terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do

324341 (sgrArgsForState state)

325342 `mappend` setColors

326343 where

344+ urlAttrs = writeURLEscapes (urlDiff diffs)

327345 colorMap = case useAltColorMap terminfoCaps of

328346 False -> ansiColorIndex

329347 True -> altColorIndex