@@ -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