git.iko.soy/vty
on master help sign in
Make hyperlinking optional (fixes #137)

This change makes it so that: * Hyperlinking (emitted using 'withURL') by default is disabled. * Hyperlinking can be enabled with 'setMode (outputIface vty) Hyperlink True'. In particular, some terminals, contrary to the aspirations of the terminal hyperlinking proposal[1], do not gracefully hide/ignore unknown OSC sequences[2]. This change makes it so that Vty users need to opt in to using hyperlinking and makes it clear that the feature may or may not be very well-supported and that they should do adequate testing on the terminal emulators they wish to support. [1] https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda [2] https://github.com/jtdaugherty/vty/issues/137

commit55d46f50f4a534faedb66d994353e91e0edfcace authorJonathan Daugherty <cygnus@foobox.com> dateSat 2 Dec 2017, 14:36 (9 years ago) parent4f5e742
6 files changed+89−44
compare with master
unifiedsplit
src/Graphics/Vty/Attributes.hs+6−2 src/Graphics/Vty/Inline.hs+27−14 src/Graphics/Vty/Output/Interface.hs+22−15 src/Graphics/Vty/Output/Mock.hs+2−2 src/Graphics/Vty/Output/TerminfoBased.hs+30−11 src/Graphics/Vty/Output/XTermColor.hs+2
src/Graphics/Vty/Attributes.hs+6−2
@@ -215,8 +215,12 @@ withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFl
215215-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
216216-- These escape sequences are comparatively new and aren't widely
217217-- 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.
218+-- that don't know about these sequences will ignore these sequences,
219+-- and therefore this should fall back sensibly. In some cases they
220+-- won't and this will result in garbage, so this is why hyperlinking is
221+-- disabled by default, in which case this combinator has no observable
222+-- effect. To enable it, enable 'Hyperlink' mode on your Vty output
223+-- interface.
220224withURL :: Attr -> Text -> Attr
221225withURL attr url = attr { attrURL = SetTo url }
222226
src/Graphics/Vty/Inline.hs+27−14
@@ -48,22 +48,33 @@ import Data.IORef
4848
4949import System.IO
5050
51−type InlineM v = State Attr v
51+type InlineM v = State InlineState v
52+
53+data InlineState =
54+ InlineState { inlineAttr :: Attr
55+ , inlineUrlsEnabled :: Bool
56+ }
5257
5358-- | Set the background color to the provided 'Color'.
5459backColor :: Color -> InlineM ()
55−backColor c = modify $ flip mappend ( currentAttr `withBackColor` c )
60+backColor c = modify $ \s ->
61+ s { inlineAttr = inlineAttr s `mappend` (currentAttr `withBackColor` c)
62+ }
5663
5764-- | Set the foreground color to the provided 'Color'.
5865foreColor :: Color -> InlineM ()
59−foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c )
66+foreColor c = modify $ \s ->
67+ s { inlineAttr = inlineAttr s `mappend` (currentAttr `withForeColor` c)
68+ }
6069
6170-- | Attempt to change the 'Style' of the following text..
6271--
6372-- If the terminal does not support the style change then no error is
6473-- produced. The style can still be removed.
6574applyStyle :: Style -> InlineM ()
66−applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )
75+applyStyle st = modify $ \s ->
76+ s { inlineAttr = inlineAttr s `mappend` (currentAttr `withStyle` st)
77+ }
6778
6879-- | Attempt to remove the specified 'Style' from the display of the
6980-- following text.
@@ -71,16 +82,18 @@ applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )
7182-- This will fail if 'applyStyle' for the given style has not been
7283-- previously called.
7384removeStyle :: Style -> InlineM ()
74−removeStyle sMask = modify $ \attr ->
75− let style' = case attrStyle attr of
76− Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
77− KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
78− SetTo s -> s .&. complement sMask
79− in attr { attrStyle = SetTo style' }
85+removeStyle sMask = modify $ \s ->
86+ s { inlineAttr =
87+ let style' = case attrStyle (inlineAttr s) of
88+ Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
89+ KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
90+ SetTo st -> st .&. complement sMask
91+ in (inlineAttr s) { attrStyle = SetTo style' }
92+ }
8093
8194-- | Reset the display attributes.
8295defaultAll :: InlineM ()
83−defaultAll = put defAttr
96+defaultAll = modify $ \s -> s { inlineAttr = defAttr }
8497
8598-- | Apply the provided display attribute changes to the given terminal
8699-- output device.
@@ -93,14 +106,14 @@ putAttrChange out c = liftIO $ do
93106 mfattr <- prevFattr <$> readIORef (assumedStateRef out)
94107 fattr <- case mfattr of
95108 Nothing -> do
96− liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc
109+ liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False
97110 return $ FixedAttr defaultStyleMask Nothing Nothing Nothing
98111 Just v -> return v
99− let attr = execState c currentAttr
112+ let InlineState attr urlsEnabled = execState c (InlineState currentAttr False)
100113 attr' = limitAttrForDisplay out attr
101114 fattr' = fixDisplayAttr fattr attr'
102115 diffs = displayAttrDiffs fattr fattr'
103− outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs
116+ outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs
104117 modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }
105118 inlineHack dc
106119
src/Graphics/Vty/Output/Interface.hs+22−15
@@ -47,6 +47,12 @@ data Mode = Mouse
4747 | Focus
4848 -- ^ Focus-in/focus-out events (whether the terminal is
4949 -- configured to provide events on focus change)
50+ | Hyperlink
51+ -- ^ Hyperlink mode via the 'withURL' attribute modifier (see
52+ -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
53+ -- Note that this may not work gracefully in all terminal
54+ -- emulators so be sure to test this mode with the terminals
55+ -- you intend to support.
5056 deriving (Eq, Read, Show)
5157
5258-- | The Vty terminal output interface.
@@ -133,9 +139,9 @@ data DisplayContext = DisplayContext
133139 -- to support this the currently applied display attributes are
134140 -- required. In addition it may be possible to optimize the state
135141 -- changes based off the currently applied display attributes.
136− , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
142+ , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
137143 -- | Reset the display attributes to the default display attributes.
138− , writeDefaultAttr :: Write
144+ , writeDefaultAttr :: Bool -> Write
139145 , writeRowEnd :: Write
140146 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
141147 , inlineHack :: IO ()
@@ -159,6 +165,7 @@ writeUtf8Text = writeByteString
159165-- 5. The cursor is then shown and positioned or kept hidden.
160166outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()
161167outputPicture dc pic = liftIO $ do
168+ urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink
162169 as <- readIORef (assumedStateRef $ contextDevice dc)
163170 let manipCursor = supportsCursorVisibility (contextDevice dc)
164171 r = contextRegion dc
@@ -174,7 +181,7 @@ outputPicture dc pic = liftIO $ do
174181 (Vector.toList ops)
175182 -- build the Write corresponding to the output image
176183 out = (if manipCursor then writeHideCursor dc else mempty)
177− `mappend` writeOutputOps dc initialAttr diffs ops
184+ `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops
178185 `mappend`
179186 (let (w,h) = contextRegion dc
180187 clampX = max 0 . min (w-1)
@@ -197,15 +204,15 @@ outputPicture dc pic = liftIO $ do
197204 let as' = as { prevOutputOps = Just ops }
198205 writeIORef (assumedStateRef $ contextDevice dc) as'
199206
200−writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
201−writeOutputOps dc initialAttr diffs ops =
207+writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
208+writeOutputOps urlsEnabled dc initialAttr diffs ops =
202209 let (_, out, _) = Vector.foldl' writeOutputOps'
203210 (0, mempty, diffs)
204211 ops
205212 in out
206213 where
207214 writeOutputOps' (y, out, True : diffs') spanOps
208− = let spanOut = writeSpanOps dc y initialAttr spanOps
215+ = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps
209216 out' = out `mappend` spanOut
210217 in (y+1, out', diffs')
211218 writeOutputOps' (y, out, False : diffs') _spanOps
@@ -213,27 +220,27 @@ writeOutputOps dc initialAttr diffs ops =
213220 writeOutputOps' (_y, _out, []) _spanOps
214221 = error "vty - output spans without a corresponding diff."
215222
216−writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
217−writeSpanOps dc y initialAttr spanOps =
223+writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
224+writeSpanOps urlsEnabled dc y initialAttr spanOps =
218225 -- The first operation is to set the cursor to the start of the row
219− let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc
226+ let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled
220227 -- then the span ops are serialized in the order specified
221− in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of
228+ in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of
222229 (opOut, fattr') -> (out `mappend` opOut, fattr')
223230 )
224231 (start, initialAttr)
225232 spanOps
226233
227−writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
228−writeSpanOp dc (TextSpan attr _ _ str) fattr =
234+writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
235+writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =
229236 let attr' = limitAttrForDisplay (contextDevice dc) attr
230237 fattr' = fixDisplayAttr fattr attr'
231238 diffs = displayAttrDiffs fattr fattr'
232− out = writeSetAttr dc fattr attr' diffs
239+ out = writeSetAttr dc urlsEnabled fattr attr' diffs
233240 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
234241 in (out, fattr')
235−writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"
236−writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr)
242+writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"
243+writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)
237244
238245-- | The cursor position is given in X,Y character offsets. Due to
239246-- multi-column characters this needs to be translated to column, row
src/Graphics/Vty/Output/Mock.hs+2−2
@@ -72,10 +72,10 @@ mockTerminal r = liftIO $ do
7272 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'
7373 -- An attr change is always visualized as the single
7474 -- character 'A'
75− , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
75+ , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'
7676 -- default attr is always visualized as the single
7777 -- character 'D'
78− , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D'
78+ , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D'
7979 -- row end is always visualized as the single character
8080 -- 'E'
8181 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'
src/Graphics/Vty/Output/TerminfoBased.hs+30−11
@@ -120,6 +120,25 @@ reserveTerminal termName outFd = liftIO $ do
120120 Just setb -> setb
121121 Nothing -> error $ "no back color support for terminal " ++ termName
122122 Just setab -> setab
123+
124+ hyperlinkModeStatus <- newIORef False
125+ newAssumedStateRef <- newIORef initialAssumedState
126+
127+ let terminfoSetMode m newStatus = do
128+ curStatus <- terminfoModeStatus m
129+ when (newStatus /= curStatus) $
130+ case m of
131+ Hyperlink -> liftIO $ do
132+ writeIORef hyperlinkModeStatus newStatus
133+ writeIORef newAssumedStateRef initialAssumedState
134+ _ -> return ()
135+ terminfoModeStatus m =
136+ case m of
137+ Hyperlink -> liftIO $ readIORef hyperlinkModeStatus
138+ _ -> return False
139+ terminfoModeSupported Hyperlink = True
140+ terminfoModeSupported _ = False
141+
123142 terminfoCaps <- pure TerminfoCaps
124143 <*> probeCap ti "smcup"
125144 <*> probeCap ti "rmcup"
@@ -135,7 +154,6 @@ reserveTerminal termName outFd = liftIO $ do
135154 <*> requireCap ti "el"
136155 <*> currentDisplayAttrCaps ti
137156 <*> probeCap ti "bel"
138− newAssumedStateRef <- newIORef initialAssumedState
139157 let t = Output
140158 { terminalID = termName
141159 , releaseTerminal = liftIO $ do
@@ -171,9 +189,9 @@ reserveTerminal termName outFd = liftIO $ do
171189 Just v -> toEnum v
172190 True -> 1
173191 , supportsCursorVisibility = isJust $ civis terminfoCaps
174− , supportsMode = const False
175− , setMode = const $ const $ return ()
176− , getModeStatus = const $ return False
192+ , supportsMode = terminfoModeSupported
193+ , setMode = terminfoSetMode
194+ , getModeStatus = terminfoModeStatus
177195 , assumedStateRef = newAssumedStateRef
178196 -- I think fix would help assure tActual is the only
179197 -- reference. I was having issues tho.
@@ -235,9 +253,9 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
235253 Nothing -> error "this terminal does not support hide cursor"
236254 Just c -> writeCapExpr c []
237255 , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
238− , writeDefaultAttr =
256+ , writeDefaultAttr = \urlsEnabled ->
239257 writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
240− writeURLEscapes EndLink
258+ (if urlsEnabled then writeURLEscapes EndLink else mempty)
241259 , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
242260 , inlineHack = return ()
243261 }
@@ -292,9 +310,9 @@ writeURLEscapes NoLinkChange =
292310--
293311-- Note that this optimizes for fewer state changes followed by fewer
294312-- bytes.
295−terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
296−terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
297− urlAttrs `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
313+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
314+terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs = do
315+ urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
298316 -- The only way to reset either color, portably, to the default
299317 -- is to use either the set state capability or the set default
300318 -- capability.
@@ -303,7 +321,7 @@ terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
303321 (fixedStyle attr )
304322 (styleToApplySeq $ fixedStyle attr) of
305323 -- only way to reset a color to the defaults
306− EnterExitSeq caps -> writeDefaultAttr dc
324+ EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
307325 `mappend`
308326 foldMap (\cap -> writeCapExpr cap []) caps
309327 `mappend`
@@ -343,7 +361,8 @@ terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
343361 (sgrArgsForState state)
344362 `mappend` setColors
345363 where
346− urlAttrs = writeURLEscapes (urlDiff diffs)
364+ urlAttrs True = writeURLEscapes (urlDiff diffs)
365+ urlAttrs False = mempty
347366 colorMap = case useAltColorMap terminfoCaps of
348367 False -> ansiColorIndex
349368 True -> altColorIndex
src/Graphics/Vty/Output/XTermColor.hs+2
@@ -61,10 +61,12 @@ reserveTerminal variant outFd = liftIO $ do
6161 True -> flushedPut enableBracketedPastes
6262 False -> flushedPut disableBracketedPastes
6363 writeIORef pasteModeStatus newStatus
64+ Hyperlink -> setMode t Hyperlink newStatus
6465
6566 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
6667 xtermGetMode Focus = liftIO $ readIORef focusModeStatus
6768 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
69+ xtermGetMode Hyperlink = getModeStatus t Hyperlink
6870
6971 let t' = t
7072 { terminalID = terminalID t ++ " (xterm-color)"