git.iko.soy/vty
on master help sign in
Add support for SGR (extended) mouse events for XTermColor terminals
7b075ceJonathan Daugherty
src/Graphics/Vty/Input/Classify.hs+3−6
compare with master
unifiedsplit
@@ -12,6 +12,8 @@ module Graphics.Vty.Input.Classify
12 ) where
12 ) where
13
13
14import Graphics.Vty.Input.Events
14import Graphics.Vty.Input.Events
15+import Graphics.Vty.Input.Mouse
16+import Graphics.Vty.Input.Classify.Types
15
17
16import Codec.Binary.UTF8.Generic (decode)
18import Codec.Binary.UTF8.Generic (decode)
17
19
@@ -23,12 +25,6 @@ import qualified Data.Set as S( fromList, member )
23import Data.Char
25import Data.Char
24import Data.Word
26import Data.Word
25
27
26−data KClass
27− = Valid Event [Char]
28− | Invalid
29− | Prefix
30− deriving(Show, Eq)
31−
32compile :: ClassifyMap -> [Char] -> KClass
28compile :: ClassifyMap -> [Char] -> KClass
33compile table = cl' where
29compile table = cl' where
34 -- take all prefixes and create a set of these
30 -- take all prefixes and create a set of these
@@ -60,6 +56,7 @@ classify :: ClassifyMap -> [Char] -> KClass
60classify table =
56classify table =
61 let standardClassifier = compile table
57 let standardClassifier = compile table
62 in \s -> case s of
58 in \s -> case s of
59+ ('\ESC':'[':'<':cs) | length cs >= 6 -> classifySGRMouseEvent cs
63 c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
60 c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
64 _ -> standardClassifier s
61 _ -> standardClassifier s
65
62
src/Graphics/Vty/Input/Classify/Types.hsnew file+11
@@ -0,0 +1,11 @@
1+module Graphics.Vty.Input.Classify.Types
2+ ( KClass(..)
3+ ) where
4+
5+import Graphics.Vty.Input.Events
6+
7+data KClass
8+ = Valid Event [Char]
9+ | Invalid
10+ | Prefix
11+ deriving(Show, Eq)
src/Graphics/Vty/Input/Events.hs+2−1
@@ -31,7 +31,8 @@ data Button = BLeft | BMiddle | BRight
31data Event
31data Event
32 = EvKey Key [Modifier]
32 = EvKey Key [Modifier]
33 -- | \todo mouse events are not supported
33 -- | \todo mouse events are not supported
34− | EvMouse Int Int Button [Modifier]
34+ | EvMouseDown Int Int Button [Modifier]
35+ | EvMouseUp Int Int Button
35 -- | if read from 'eventChannel' this is the size at the time of the signal. If read from
36 -- | if read from 'eventChannel' this is the size at the time of the signal. If read from
36 -- 'nextEvent' this is the size at the time the event was processed by Vty. Typically these are
37 -- 'nextEvent' this is the size at the time the event was processed by Vty. Typically these are
37 -- the same, but if somebody is resizing the terminal quickly they can be different.
38 -- the same, but if somebody is resizing the terminal quickly they can be different.
src/Graphics/Vty/Input/Mouse.hsnew file+127
@@ -0,0 +1,127 @@
1+module Graphics.Vty.Input.Mouse
2+ ( requestSGRMouseEvents
3+ , classifySGRMouseEvent
4+ ) where
5+
6+import Graphics.Vty.Input.Events
7+import Graphics.Vty.Input.Classify.Types
8+
9+import Control.Monad.Trans.Maybe
10+import Control.Monad.State
11+import Data.Maybe (catMaybes)
12+import Data.Bits ((.&.))
13+
14+-- This implementation was informed by
15+--
16+-- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
17+
18+-- A mouse event in SGR extended mode is
19+--
20+-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
21+--
22+-- where
23+--
24+-- * B is the number with button and modifier bits set,
25+-- * X is the X coordinate of the event starting at 1
26+-- * Y is the Y coordinate of the event starting at 1
27+-- * the final character is 'M' for a press, 'm' for a release
28+
29+-- | These sequences set xterm-based terminals to send mouse event
30+-- sequences. This requests SGR extended mouse events.
31+requestSGRMouseEvents :: String
32+requestSGRMouseEvents = "\ESC[?1000h\ESC[?1006h"
33+
34+-- Modifier bits:
35+shiftBit :: Int
36+shiftBit = 4
37+
38+metaBit :: Int
39+metaBit = 8
40+
41+ctrlBit :: Int
42+ctrlBit = 16
43+
44+-- These bits indicate the buttons involved:
45+buttonMask :: Int
46+buttonMask = 3
47+
48+leftButton :: Int
49+leftButton = 0
50+
51+middleButton :: Int
52+middleButton = 1
53+
54+rightButton :: Int
55+rightButton = 2
56+
57+hasBitSet :: Int -> Int -> Bool
58+hasBitSet val bit = val .&. bit > 0
59+
60+-- Given a modifer/button value, determine which button was indicated
61+getButton :: Int -> Parser Button
62+getButton mods =
63+ let buttonMap = [ (leftButton, BLeft)
64+ , (middleButton, BMiddle)
65+ , (rightButton, BRight)
66+ ]
67+ in case lookup (mods .&. buttonMask) buttonMap of
68+ Nothing -> failParse
69+ Just b -> return b
70+
71+getModifiers :: Int -> [Modifier]
72+getModifiers mods =
73+ catMaybes [ if mods `hasBitSet` shiftBit then Just MShift else Nothing
74+ , if mods `hasBitSet` metaBit then Just MMeta else Nothing
75+ , if mods `hasBitSet` ctrlBit then Just MCtrl else Nothing
76+ ]
77+
78+type Parser a = MaybeT (State String) a
79+
80+runParser :: String -> Parser Event -> KClass
81+runParser s parser =
82+ case runState (runMaybeT parser) s of
83+ (Nothing, _) -> Invalid
84+ (Just e, remaining) -> Valid e remaining
85+
86+failParse :: Parser a
87+failParse = fail "invalid parse"
88+
89+readInt :: Parser Int
90+readInt = do
91+ s <- get
92+ case (reads :: ReadS Int) s of
93+ [(i, rest)] -> do
94+ put rest
95+ return i
96+ _ -> failParse
97+
98+readChar :: Parser Char
99+readChar = do
100+ s <- get
101+ case s of
102+ c:rest -> put rest >> return c
103+ _ -> failParse
104+
105+expectChar :: Char -> Parser ()
106+expectChar c = do
107+ c' <- readChar
108+ if c' == c then return () else failParse
109+
110+-- Attempt to classify a control sequence as an SGR mouse event. To
111+-- get here we should have already read "\ESC[<" so that will not be
112+-- included in the string to be parsed.
113+classifySGRMouseEvent :: [Char] -> KClass
114+classifySGRMouseEvent s = runParser s $ do
115+ mods <- readInt
116+ expectChar ';'
117+ xCoord <- readInt
118+ expectChar ';'
119+ yCoord <- readInt
120+ final <- readChar
121+
122+ let modifiers = getModifiers mods
123+ button <- getButton mods
124+ case final of
125+ 'M' -> return $ EvMouseDown xCoord yCoord button modifiers
126+ 'm' -> return $ EvMouseUp xCoord yCoord button
127+ _ -> failParse
src/Graphics/Vty/Output/XTermColor.hs+2
@@ -9,6 +9,7 @@ module Graphics.Vty.Output.XTermColor ( reserveTerminal )
9 where
9 where
10
10
11import Graphics.Vty.Output.Interface
11import Graphics.Vty.Output.Interface
12+import Graphics.Vty.Input.Mouse (requestSGRMouseEvents)
12import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
13import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
13
14
14import Blaze.ByteString.Builder (writeToByteString)
15import Blaze.ByteString.Builder (writeToByteString)
@@ -33,6 +34,7 @@ reserveTerminal variant outFd = liftIO $ do
33 -- xterm-color is broken.
34 -- xterm-color is broken.
34 let variant' = if variant == "xterm-color" then "xterm" else variant
35 let variant' = if variant == "xterm-color" then "xterm" else variant
35 flushedPut setUtf8CharSet
36 flushedPut setUtf8CharSet
37+ flushedPut requestSGRMouseEvents
36 t <- TerminfoBased.reserveTerminal variant' outFd
38 t <- TerminfoBased.reserveTerminal variant' outFd
37 let t' = t
39 let t' = t
38 { terminalID = terminalID t ++ " (xterm-color)"
40 { terminalID = terminalID t ++ " (xterm-color)"
vty.cabal+2
@@ -94,7 +94,9 @@ library
94 Graphics.Vty.DisplayAttributes
94 Graphics.Vty.DisplayAttributes
95 Graphics.Vty.Image.Internal
95 Graphics.Vty.Image.Internal
96 Graphics.Vty.Input.Classify
96 Graphics.Vty.Input.Classify
97+ Graphics.Vty.Input.Classify.Types
97 Graphics.Vty.Input.Loop
98 Graphics.Vty.Input.Loop
99+ Graphics.Vty.Input.Mouse
98 Graphics.Vty.Input.Terminfo
100 Graphics.Vty.Input.Terminfo
99 Graphics.Vty.PictureToSpans
101 Graphics.Vty.PictureToSpans
100 Graphics.Vty.Span
102 Graphics.Vty.Span