module Graphics.Vty.Input.Mouse
( requestMouseEvents
, disableMouseEvents
, isMouseEvent
, classifyMouseEvent
)
where
import Graphics.Vty.Input.Events
import Graphics.Vty.Input.Classify.Types
import Graphics.Vty.Input.Classify.Parse
import Control.Monad.State
import Data.List (isPrefixOf)
import Data.Maybe (catMaybes)
import Data.Bits ((.&.))
requestMouseEvents :: String
requestMouseEvents :: String
requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h"
disableMouseEvents :: String
disableMouseEvents :: String
disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l"
isMouseEvent :: String -> Bool
isMouseEvent :: String -> Bool
isMouseEvent s :: String
s = String -> Bool
isSGREvent String
s Bool -> Bool -> Bool
|| String -> Bool
isNormalEvent String
s
isSGREvent :: String -> Bool
isSGREvent :: String -> Bool
isSGREvent = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
sgrPrefix
sgrPrefix :: String
sgrPrefix :: String
sgrPrefix = "\ESC[M"
isNormalEvent :: String -> Bool
isNormalEvent :: String -> Bool
isNormalEvent = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
normalPrefix
normalPrefix :: String
normalPrefix :: String
normalPrefix = "\ESC[<"
shiftBit :: Int
shiftBit :: Int
shiftBit = 4
metaBit :: Int
metaBit :: Int
metaBit = 8
ctrlBit :: Int
ctrlBit :: Int
ctrlBit = 16
buttonMask :: Int
buttonMask :: Int
buttonMask = 67
leftButton :: Int
leftButton :: Int
leftButton = 0
middleButton :: Int
middleButton :: Int
middleButton = 1
rightButton :: Int
rightButton :: Int
rightButton = 2
scrollUp :: Int
scrollUp :: Int
scrollUp = 64
scrollDown :: Int
scrollDown :: Int
scrollDown = 65
hasBitSet :: Int -> Int -> Bool
hasBitSet :: Int -> Int -> Bool
hasBitSet val :: Int
val bit :: Int
bit = Int
val Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
bit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
classifyMouseEvent :: String -> KClass
classifyMouseEvent :: String -> KClass
classifyMouseEvent s :: String
s = String -> Parser Event -> KClass
runParser String
s (Parser Event -> KClass) -> Parser Event -> KClass
forall a b. (a -> b) -> a -> b
$ do
Bool -> MaybeT (State String) () -> MaybeT (State String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
isMouseEvent String
s) MaybeT (State String) ()
forall a. Parser a
failParse
Char -> MaybeT (State String) ()
expectChar '\ESC'
Char -> MaybeT (State String) ()
expectChar '['
Char
ty <- Parser Char
readChar
case Char
ty of
'<' -> Parser Event
classifySGRMouseEvent
'M' -> Parser Event
classifyNormalMouseEvent
_ -> Parser Event
forall a. Parser a
failParse
getSGRButton :: Int -> Parser Button
getSGRButton :: Int -> Parser Button
getSGRButton mods :: Int
mods =
let buttonMap :: [(Int, Button)]
buttonMap = [ (Int
leftButton, Button
BLeft)
, (Int
middleButton, Button
BMiddle)
, (Int
rightButton, Button
BRight)
, (Int
scrollUp, Button
BScrollUp)
, (Int
scrollDown, Button
BScrollDown)
]
in case Int -> [(Int, Button)] -> Maybe Button
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Int
mods Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
buttonMask) [(Int, Button)]
buttonMap of
Nothing -> Parser Button
forall a. Parser a
failParse
Just b :: Button
b -> Button -> Parser Button
forall (m :: * -> *) a. Monad m => a -> m a
return Button
b
getModifiers :: Int -> [Modifier]
getModifiers :: Int -> [Modifier]
getModifiers mods :: Int
mods =
[Maybe Modifier] -> [Modifier]
forall a. [Maybe a] -> [a]
catMaybes [ if Int
mods Int -> Int -> Bool
`hasBitSet` Int
shiftBit then Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
MShift else Maybe Modifier
forall a. Maybe a
Nothing
, if Int
mods Int -> Int -> Bool
`hasBitSet` Int
metaBit then Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
MMeta else Maybe Modifier
forall a. Maybe a
Nothing
, if Int
mods Int -> Int -> Bool
`hasBitSet` Int
ctrlBit then Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
MCtrl else Maybe Modifier
forall a. Maybe a
Nothing
]
classifyNormalMouseEvent :: Parser Event
classifyNormalMouseEvent :: Parser Event
classifyNormalMouseEvent = do
Char
statusChar <- Parser Char
readChar
Char
xCoordChar <- Parser Char
readChar
Char
yCoordChar <- Parser Char
readChar
let xCoord :: Int
xCoord = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
xCoordChar Int -> Int -> Int
forall a. Num a => a -> a -> a
- 32
yCoord :: Int
yCoord = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
yCoordChar Int -> Int -> Int
forall a. Num a => a -> a -> a
- 32
status :: Int
status = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
statusChar
modifiers :: [Modifier]
modifiers = Int -> [Modifier]
getModifiers Int
status
let press :: Bool
press = Int
status Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
buttonMask Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 3
case Bool
press of
True -> do
Button
button <- Int -> Parser Button
getSGRButton Int
status
Event -> Parser Event
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> Parser Event) -> Event -> Parser Event
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Button -> [Modifier] -> Event
EvMouseDown (Int
xCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (Int
yCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Button
button [Modifier]
modifiers
False -> Event -> Parser Event
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> Parser Event) -> Event -> Parser Event
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Maybe Button -> Event
EvMouseUp (Int
xCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (Int
yCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Maybe Button
forall a. Maybe a
Nothing
classifySGRMouseEvent :: Parser Event
classifySGRMouseEvent :: Parser Event
classifySGRMouseEvent = do
Int
mods <- Parser Int
readInt
Char -> MaybeT (State String) ()
expectChar ';'
Int
xCoord <- Parser Int
readInt
Char -> MaybeT (State String) ()
expectChar ';'
Int
yCoord <- Parser Int
readInt
Char
final <- Parser Char
readChar
let modifiers :: [Modifier]
modifiers = Int -> [Modifier]
getModifiers Int
mods
Button
button <- Int -> Parser Button
getSGRButton Int
mods
case Char
final of
'M' -> Event -> Parser Event
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> Parser Event) -> Event -> Parser Event
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Button -> [Modifier] -> Event
EvMouseDown (Int
xCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (Int
yCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Button
button [Modifier]
modifiers
'm' -> Event -> Parser Event
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> Parser Event) -> Event -> Parser Event
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Maybe Button -> Event
EvMouseUp (Int
xCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (Int
yCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (Button -> Maybe Button
forall a. a -> Maybe a
Just Button
button)
_ -> Parser Event
forall a. Parser a
failParse