Add support for strikethrough mode

This change adds a new 'strikethrough' Style value and uses the 'smxx'
and 'rmxx' Terminfo capabilities to activate and deactivate
strikethrough mode, respectively. If the terminfo does not report those
capabilities, this style is ignored.

For details, see

https://invisible-island.net/xterm/terminfo-contents.html#tic-ecma_strikeout

src/Graphics/Vty/Attributes.hs

@@ -43,6 +43,7 @@ module Graphics.Vty.Attributes
   , withStyle
   , standout
   , italic
+  , strikethrough
   , underline
   , reverseVideo
   , blink
@@ -181,7 +182,7 @@ instance Eq v => Monoid ( MaybeDefault v ) where
 -- if the style attribute should not be applied.
 type Style = Word8
 
--- | The 7 possible style attributes:
+-- | Valid style attributes include:
 --
 --      * standout
 --
@@ -197,9 +198,11 @@ type Style = Word8
 --
 --      * italic
 --
+--      * strikethrough (via the smxx/rmxx terminfo capabilities)
+--
 --  (The invisible, protect, and altcharset display attributes some
 --  terminals support are not supported via VTY.)
-standout, underline, reverseVideo, blink, dim, bold, italic :: Style
+standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
 standout        = 0x01
 underline       = 0x02
 reverseVideo    = 0x04
@@ -207,6 +210,7 @@ blink           = 0x08
 dim             = 0x10
 bold            = 0x20
 italic          = 0x40
+strikethrough   = 0x80
 
 defaultStyleMask :: Style
 defaultStyleMask = 0x00

src/Graphics/Vty/DisplayAttributes.hs

@@ -96,6 +96,8 @@ data StyleStateChange
     | RemoveStandout
     | ApplyItalic
     | RemoveItalic
+    | ApplyStrikethrough
+    | RemoveStrikethrough
     | ApplyUnderline
     | RemoveUnderline
     | ApplyReverseVideo
@@ -144,6 +146,7 @@ diffStyles prev cur
     [ styleDiff standout      ApplyStandout     RemoveStandout
     , styleDiff underline     ApplyUnderline    RemoveUnderline
     , styleDiff italic        ApplyItalic       RemoveItalic
+    , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
     , styleDiff reverseVideo  ApplyReverseVideo RemoveReverseVideo
     , styleDiff blink         ApplyBlink        RemoveBlink
     , styleDiff dim           ApplyDim          RemoveDim

src/Graphics/Vty/Output/TerminfoBased.hs

@@ -68,6 +68,8 @@ data DisplayAttrCaps = DisplayAttrCaps
     , exitStandout :: Maybe CapExpression
     , enterItalic :: Maybe CapExpression
     , exitItalic :: Maybe CapExpression
+    , enterStrikethrough :: Maybe CapExpression
+    , exitStrikethrough :: Maybe CapExpression
     , enterUnderline :: Maybe CapExpression
     , exitUnderline :: Maybe CapExpression
     , enterReverseVideo :: Maybe CapExpression
@@ -235,6 +237,8 @@ currentDisplayAttrCaps ti
     <*> probeCap ti "rmso"
     <*> probeCap ti "sitm"
     <*> probeCap ti "ritm"
+    <*> probeCap ti "smxx"
+    <*> probeCap ti "rmxx"
     <*> probeCap ti "smul"
     <*> probeCap ti "rmul"
     <*> probeCap ti "rev"
@@ -270,7 +274,11 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
             , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
             , writeDefaultAttr = \urlsEnabled ->
                 writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
-                (if urlsEnabled then writeURLEscapes EndLink else mempty)
+                (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`
+                (case exitStrikethrough $ displayAttrCaps terminfoCaps of
+                    Just cap -> writeCapExpr cap []
+                    Nothing -> mempty
+                )
             , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
             , inlineHack = return ()
             }
@@ -348,6 +356,7 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
                                                )
                                                (sgrArgsForState state)
                                   `mappend` setItalics
+                                  `mappend` setStrikethrough
                                   `mappend` setColors
         -- Otherwise the display colors are not changing or changing
         -- between two non-default points.
@@ -375,6 +384,7 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
                                                )
                                                (sgrArgsForState state)
                                   `mappend` setItalics
+                                  `mappend` setStrikethrough
                                   `mappend` setColors
     where
         urlAttrs True = writeURLEscapes (urlDiff diffs)
@@ -392,6 +402,11 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
           , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)
           = writeCapExpr sitm []
           | otherwise = mempty
+        setStrikethrough
+          | hasStyle (fixedStyle attr) strikethrough
+          , Just smxx <- enterStrikethrough (displayAttrCaps terminfoCaps)
+          = writeCapExpr smxx []
+          | otherwise = mempty
         setColors =
             (case fixedForeColor attr of
                 Just c -> writeCapExpr (setForeColor terminfoCaps)
@@ -460,6 +475,7 @@ data DisplayAttrState = DisplayAttrState
     { applyStandout :: Bool
     , applyUnderline :: Bool
     , applyItalic :: Bool
+    , applyStrikethrough :: Bool
     , applyReverseVideo :: Bool
     , applyBlink :: Bool
     , applyDim :: Bool
@@ -496,6 +512,8 @@ reqDisplayCapSeqFor caps s diffs
         -- set state cap then just use the set state cap.
         ( True, True  ) -> SetState $ stateForStyle s
     where
+        noEnterExitCap ApplyStrikethrough = isNothing $ enterStrikethrough caps
+        noEnterExitCap RemoveStrikethrough = isNothing $ exitStrikethrough caps
         noEnterExitCap ApplyItalic = isNothing $ enterItalic caps
         noEnterExitCap RemoveItalic = isNothing $ exitItalic caps
         noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
@@ -510,6 +528,8 @@ reqDisplayCapSeqFor caps s diffs
         noEnterExitCap RemoveDim = True
         noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
         noEnterExitCap RemoveBold = True
+        enterExitCap ApplyStrikethrough = fromJust $ enterStrikethrough caps
+        enterExitCap RemoveStrikethrough = fromJust $ exitStrikethrough caps
         enterExitCap ApplyItalic = fromJust $ enterItalic caps
         enterExitCap RemoveItalic = fromJust $ exitItalic caps
         enterExitCap ApplyStandout = fromJust $ enterStandout caps
@@ -526,6 +546,7 @@ stateForStyle s = DisplayAttrState
     { applyStandout = isStyleSet standout
     , applyUnderline = isStyleSet underline
     , applyItalic = isStyleSet italic
+    , applyStrikethrough = isStyleSet strikethrough
     , applyReverseVideo = isStyleSet reverseVideo
     , applyBlink = isStyleSet blink
     , applyDim = isStyleSet dim
@@ -538,6 +559,7 @@ styleToApplySeq s = concat
     [ applyIfRequired ApplyStandout standout
     , applyIfRequired ApplyUnderline underline
     , applyIfRequired ApplyItalic italic
+    , applyIfRequired ApplyStrikethrough strikethrough
     , applyIfRequired ApplyReverseVideo reverseVideo
     , applyIfRequired ApplyBlink blink
     , applyIfRequired ApplyDim dim