826b99a · vty · git.iko.soy

git.iko.soy/vty

Merge pull request #134 from aisamanra/master

Add an experimental Attr for hyperlink escape sequences

commit826b99a40584733c8000650e2e05212f31eebf56 authorJonathan Daugherty <cygnus@foobox.com> dateFri 6 Oct 2017, 12:43 (9 years ago) parent452ed52 9bd42a9

5 files changed+72−9

compare with master

unifiedsplit

src/Graphics/Vty/Attributes.hs+20−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+20−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,21 @@ withStyle :: Attr -> Style -> Attr

203210withStyle attr 0 = attr

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

205212

213+-- | Add a hyperlinked URL using the proposed [escape sequences for

214+-- hyperlinked

215+-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).

216+-- These escape sequences are comparatively new and aren't widely

217+-- supported in terminal emulators yet, but most terminal emulators

218+-- that don't know about these sequences will ignore these

219+-- sequences, and therefore this should fall back sensibly.

220+withURL :: Attr -> Text -> Attr

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

222+

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

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

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

209226defAttr :: Attr

210−defAttr = Attr Default Default Default

227+defAttr = Attr Default Default Default Default

211228

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

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

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

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

218235-- with the foreground color set to brightMagenta.

219236currentAttr :: Attr

220−currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent

237+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