Merge pull request #1 from jtdaugherty/master

sync
jtdaugherty · Feb 16, 2021 · 598b014 · 598b014
2 parents 90ea183 + dfa4c1e
commit 598b014
Show file tree

Hide file tree

Showing 16 changed files with 122 additions and 35 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -1,4 +1,32 @@
 
+5.32
+----
+
+New features:
+ * Meta-PageUp and Meta-PageDown are now supported (#193)
+ * Added `supportsItalics` and `supportsStrikethrough` functions to
+   check for feature support in terminfo
+
+Bug fixes:
+ * Detect utf-8 mode in `LANG` regardless of case (thanks Emeka
+   Nkurumeh)
+
+5.31
+----
+
+New features and API changes:
+ * Added 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.
+ * `Output`: added the `setDisplayBounds` field to set the output
+   dimensions of the output handle; added an implementation of this for
+   the `TerminfoBased` backend.
+
+Other changes:
+ * The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed.
+
 5.30
 ----
 

diff --git a/src/Data/Sequence/Extra.hs b/src/Data/Sequence/Extra.hs
@@ -7,7 +7,7 @@ import Data.Sequence
 import Control.Parallel.Strategies
 
 instance NFData a => NFData (Seq a) where
-    rnf = \v -> rnf' (viewl v)
+    rnf = rnf' . viewl
         where
             rnf' EmptyL = ()
             rnf' (a :< r) = rnf a >| rnf' (viewl r)
diff --git a/src/Data/Terminfo/Parse.hs b/src/Data/Terminfo/Parse.hs
@@ -39,7 +39,7 @@ instance Show CapExpression where
         ++ " <= " ++ show (sourceString c)
         where
             hexDump :: [Word8] -> String
-            hexDump = foldr (\b s -> showHex b s) ""
+            hexDump = foldr showHex ""
 
 instance NFData CapExpression where
     rnf (CapExpression ops !_bytes !str !c !pOps)
@@ -99,7 +99,7 @@ parseCapExpression capString =
         Left e -> Left e
         Right buildResults -> Right $ constructCapExpression capString buildResults
 
-constructCapExpression :: [Char] -> BuildResults -> CapExpression
+constructCapExpression :: String -> BuildResults -> CapExpression
 constructCapExpression capString buildResults =
     let expr = CapExpression
                 { capOps = outCapOps buildResults
@@ -336,9 +336,9 @@ data BuildResults = BuildResults
 instance Semigroup BuildResults where
     v0 <> v1
         = BuildResults
-        { outParamCount = (outParamCount v0) `max` (outParamCount v1)
-        , outCapOps = (outCapOps v0) <> (outCapOps v1)
-        , outParamOps = (outParamOps v0) <> (outParamOps v1)
+        { outParamCount = outParamCount v0 `max` outParamCount v1
+        , outCapOps = outCapOps v0 <> outCapOps v1
+        , outParamOps = outParamOps v0 <> outParamOps v1
         }
 
 instance Monoid BuildResults where

diff --git a/src/Graphics/Vty/Attributes.hs b/src/Graphics/Vty/Attributes.hs
@@ -1,7 +1,4 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveAnyClass #-}
 
@@ -43,6 +40,7 @@ module Graphics.Vty.Attributes
   , withStyle
   , standout
   , italic
+  , strikethrough
   , underline
   , reverseVideo
   , blink
@@ -145,20 +143,14 @@ data FixedAttr = FixedAttr
 -- | The style and color attributes can either be the terminal defaults.
 -- Or be equivalent to the previously applied style. Or be a specific
 -- value.
-data MaybeDefault v where
-    Default :: MaybeDefault v
-    KeepCurrent :: MaybeDefault v
-    SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v
+data MaybeDefault v = Default | KeepCurrent | SetTo !v
+  deriving (Eq, Read, Show)
 
 instance (NFData v) => NFData (MaybeDefault v) where
     rnf Default = ()
     rnf KeepCurrent = ()
     rnf (SetTo v) = rnf v
 
-deriving instance Eq v => Eq (MaybeDefault v)
-deriving instance Eq v => Show (MaybeDefault v)
-deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)
-
 instance Eq v => Semigroup (MaybeDefault v) where
     Default     <> Default     = Default
     Default     <> KeepCurrent = Default
@@ -181,7 +173,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,16 +189,19 @@ 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
 blink           = 0x08
 dim             = 0x10
 bold            = 0x20
 italic          = 0x40
+strikethrough   = 0x80
 
 defaultStyleMask :: Style
 defaultStyleMask = 0x00

diff --git a/src/Graphics/Vty/DisplayAttributes.hs b/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

diff --git a/src/Graphics/Vty/Input/Classify.hs b/src/Graphics/Vty/Input/Classify.hs
@@ -24,7 +24,7 @@ import qualified Data.Set as S( fromList, member )
 import Data.Char
 import Data.Word
 
-compile :: ClassifyMap -> [Char] -> KClass
+compile :: ClassifyMap -> String -> KClass
 compile table = cl' where
     -- take all prefixes and create a set of these
     prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
@@ -51,7 +51,7 @@ compile table = cl' where
                         -- neither a prefix or a full event.
                         [] -> Invalid
 
-classify :: ClassifyMap -> [Char] -> KClass
+classify :: ClassifyMap -> String -> KClass
 classify table =
     let standardClassifier = compile table
     in \s -> case s of
@@ -64,7 +64,7 @@ classify table =
         c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
         _                    -> standardClassifier s
 
-classifyUtf8 :: Char -> [Char] -> KClass
+classifyUtf8 :: Char -> String -> KClass
 classifyUtf8 c cs =
   let n = utf8Length (ord c)
       (codepoint,rest) = splitAt n (c:cs)

diff --git a/src/Graphics/Vty/Input/Classify/Types.hs b/src/Graphics/Vty/Input/Classify/Types.hs
@@ -8,7 +8,7 @@ where
 import Graphics.Vty.Input.Events
 
 data KClass
-    = Valid Event [Char]
+    = Valid Event String
     -- ^ A valid event was parsed. Any unused characters from the input
     -- stream are also provided.
     | Invalid

diff --git a/src/Graphics/Vty/Input/Loop.hs b/src/Graphics/Vty/Input/Loop.hs
@@ -224,7 +224,7 @@ logInitialInputState input classifyTable = case _inputDebug input of
     Just h  -> do
         Config{ vmin = Just theVmin
               , vtime = Just theVtime
-              , termName = Just theTerm, .. } <- readIORef $ _configRef input
+              , termName = Just theTerm } <- readIORef $ _configRef input
         _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
         forM_ classifyTable $ \i -> case i of
             (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)

diff --git a/src/Graphics/Vty/Input/Terminfo.hs b/src/Graphics/Vty/Input/Terminfo.hs
@@ -74,7 +74,7 @@ visibleChars = [ ([x], EvKey (KChar x) [])
 ctrlChars :: ClassifyMap
 ctrlChars =
     [ ([toEnum x],EvKey (KChar y) [MCtrl])
-    | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])
+    | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])
     , y /= 'i'  -- Resolve issue #3 where CTRL-i hides TAB.
     , y /= 'h'  -- CTRL-h should not hide BS
     ]
@@ -86,8 +86,10 @@ ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars
 -- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
 specialSupportKeys :: ClassifyMap
 specialSupportKeys =
-    [ -- special support for ESC
-      ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
+    [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta])
+    , ("\ESC\ESC[6~",EvKey KPageDown [MMeta])
+    -- special support for ESC
+    , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
     -- Special support for backspace
     , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])
     -- Special support for Enter

diff --git a/src/Graphics/Vty/Output/Interface.hs b/src/Graphics/Vty/Output/Interface.hs
@@ -101,6 +101,22 @@ data Output = Output
     , ringTerminalBell :: IO ()
       -- | Returns whether the terminal has an audio bell feature.
     , supportsBell :: IO Bool
+      -- | Returns whether the terminal supports italicized text.
+      --
+      -- This is terminal-dependent and should make a best effort to
+      -- determine whether this feature is supported, but even if the
+      -- terminal advertises support (e.g. via terminfo) that might not
+      -- be a reliable indicator of whether the feature will work as
+      -- desired.
+    , supportsItalics :: IO Bool
+      -- | Returns whether the terminal supports strikethrough text.
+      --
+      -- This is terminal-dependent and should make a best effort to
+      -- determine whether this feature is supported, but even if the
+      -- terminal advertises support (e.g. via terminfo) that might not
+      -- be a reliable indicator of whether the feature will work as
+      -- desired.
+    , supportsStrikethrough :: IO Bool
     }
 
 displayContext :: Output -> DisplayRegion -> IO DisplayContext
@@ -191,6 +207,12 @@ outputPicture dc pic = do
                     AbsoluteCursor x y ->
                         writeShowCursor dc `mappend`
                         writeMoveCursor dc (clampX x) (clampY y)
+                    PositionOnly isAbs x y ->
+                        if isAbs
+                           then writeMoveCursor dc (clampX x) (clampY y)
+                           else let (ox, oy) = charToOutputPos m (clampX x, clampY y)
+                                    m = cursorOutputMap ops $ picCursor pic
+                                in writeMoveCursor dc (clampX ox) (clampY oy)
                     Cursor x y           ->
                         let m = cursorOutputMap ops $ picCursor pic
                             (ox, oy) = charToOutputPos m (clampX x, clampY y)

diff --git a/src/Graphics/Vty/Output/Mock.hs b/src/Graphics/Vty/Output/Mock.hs
@@ -48,6 +48,8 @@ mockTerminal r = liftIO $ do
             , releaseDisplay = return ()
             , ringTerminalBell = return ()
             , supportsBell = return False
+            , supportsItalics = return False
+            , supportsStrikethrough = return False
             , setDisplayBounds = const $ return ()
             , displayBounds = return r
             , outputByteBuffer = \bytes -> do

diff --git a/src/Graphics/Vty/Output/TerminfoBased.hs b/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
@@ -166,6 +168,10 @@ reserveTerminal termName outFd = do
                 sendCap setDefaultAttr []
                 maybeSendCap cnorm []
             , supportsBell = return $ isJust $ ringBellAudio terminfoCaps
+            , supportsItalics = return $ (isJust $ enterItalic (displayAttrCaps terminfoCaps)) &&
+                                         (isJust $ exitItalic (displayAttrCaps terminfoCaps))
+            , supportsStrikethrough = return $ (isJust $ enterStrikethrough (displayAttrCaps terminfoCaps)) &&
+                                               (isJust $ exitStrikethrough (displayAttrCaps terminfoCaps))
             , ringTerminalBell = maybeSendCap ringBellAudio []
             , reserveDisplay = do
                 -- If there is no support for smcup: Clear the screen
@@ -203,7 +209,7 @@ reserveTerminal termName outFd = do
             , assumedStateRef = newAssumedStateRef
             -- I think fix would help assure tActual is the only
             -- reference. I was having issues tho.
-            , mkDisplayContext = \tActual -> terminfoDisplayContext tActual terminfoCaps
+            , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
             }
         sendCap s = sendCapToTerminal t (s terminfoCaps)
         maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
@@ -235,6 +241,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 +278,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 +360,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 +388,7 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
                                                )
                                                (sgrArgsForState state)
                                   `mappend` setItalics
+                                  `mappend` setStrikethrough
                                   `mappend` setColors
     where
         urlAttrs True = writeURLEscapes (urlDiff diffs)
@@ -392,6 +406,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 +479,7 @@ data DisplayAttrState = DisplayAttrState
     { applyStandout :: Bool
     , applyUnderline :: Bool
     , applyItalic :: Bool
+    , applyStrikethrough :: Bool
     , applyReverseVideo :: Bool
     , applyBlink :: Bool
     , applyDim :: Bool
@@ -496,6 +516,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 +532,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 +550,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 +563,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