diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +5.18 +API changes: + - Added support for hyperlinking attributes (thanks Getty Ritter). This + change adds a new Attr field for containing the hyperlink to apply, + as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda + 5.17.1 - withStyle now ignores zero arguments, leaving attribute styles untouched if the input style is the null style diff --git a/src/Graphics/Vty/Attributes.hs b/src/Graphics/Vty/Attributes.hs --- a/src/Graphics/Vty/Attributes.hs +++ b/src/Graphics/Vty/Attributes.hs @@ -50,6 +50,9 @@ , withForeColor , withBackColor + -- * Setting hyperlinks + , withURL + -- * Colors , module Graphics.Vty.Attributes.Color , module Graphics.Vty.Attributes.Color240 @@ -57,6 +60,7 @@ where import Data.Bits +import Data.Text (Text) import Data.Word import Graphics.Vty.Attributes.Color @@ -73,6 +77,7 @@ { 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 @@ -- 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 @@ { 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,21 @@ withStyle attr 0 = attr withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag } +-- | Add a hyperlinked URL using the proposed [escape sequences for +-- hyperlinked +-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda). +-- These escape sequences are comparatively new and aren't widely +-- supported in terminal emulators yet, but most terminal emulators +-- that don't know about these sequences will ignore these +-- sequences, and therefore this should fall back sensibly. +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 +234,4 @@ -- 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 diff --git a/src/Graphics/Vty/DisplayAttributes.hs b/src/Graphics/Vty/DisplayAttributes.hs --- a/src/Graphics/Vty/DisplayAttributes.hs +++ b/src/Graphics/Vty/DisplayAttributes.hs @@ -6,6 +6,9 @@ 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 @@ = 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 @@ 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 @@ { 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 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 @@ | 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,7 +111,13 @@ { 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' diff --git a/src/Graphics/Vty/Inline.hs b/src/Graphics/Vty/Inline.hs --- a/src/Graphics/Vty/Inline.hs +++ b/src/Graphics/Vty/Inline.hs @@ -94,7 +94,7 @@ 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 diff --git a/src/Graphics/Vty/Output/Interface.hs b/src/Graphics/Vty/Output/Interface.hs --- a/src/Graphics/Vty/Output/Interface.hs +++ b/src/Graphics/Vty/Output/Interface.hs @@ -163,7 +163,7 @@ 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 diff --git a/src/Graphics/Vty/Output/TerminfoBased.hs b/src/Graphics/Vty/Output/TerminfoBased.hs --- a/src/Graphics/Vty/Output/TerminfoBased.hs +++ b/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 @@ 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.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 @@ , 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 @@ -- 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 @@ (sgrArgsForState state) `mappend` setColors where + urlAttrs = writeURLEscapes (urlDiff diffs) colorMap = case useAltColorMap terminfoCaps of False -> ansiColorIndex True -> altColorIndex diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -1,5 +1,5 @@ name: vty -version: 5.17.1 +version: 5.18 license: BSD3 license-file: LICENSE author: AUTHORS