-- | This module provides parsers for mouse events for both "normal" and
-- "extended" modes. This implementation was informed by
--
-- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
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 ((.&.))

-- A mouse event in SGR extended mode is
--
-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
--
-- where
--
-- * B is the number with button and modifier bits set,
-- * X is the X coordinate of the event starting at 1
-- * Y is the Y coordinate of the event starting at 1
-- * the final character is 'M' for a press, 'm' for a release

-- | These sequences set xterm-based terminals to send mouse event
-- sequences.
requestMouseEvents :: String
requestMouseEvents :: String
requestMouseEvents = String
"\ESC[?1000h\ESC[?1002h\ESC[?1006h"

-- | These sequences disable mouse events.
disableMouseEvents :: String
disableMouseEvents :: String
disableMouseEvents = String
"\ESC[?1000l\ESC[?1002l\ESC[?1006l"

-- | Does the specified string begin with a mouse event?
isMouseEvent :: String -> Bool
isMouseEvent :: String -> Bool
isMouseEvent 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 = String
"\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 = String
"\ESC[<"

-- Modifier bits:
shiftBit :: Int
shiftBit :: Int
shiftBit = Int
4

metaBit :: Int
metaBit :: Int
metaBit = Int
8

ctrlBit :: Int
ctrlBit :: Int
ctrlBit = Int
16

-- These bits indicate the buttons involved:
buttonMask :: Int
buttonMask :: Int
buttonMask = Int
67

leftButton :: Int
leftButton :: Int
leftButton = Int
0

middleButton :: Int
middleButton :: Int
middleButton = Int
1

rightButton :: Int
rightButton :: Int
rightButton = Int
2

scrollUp :: Int
scrollUp :: Int
scrollUp = Int
64

scrollDown :: Int
scrollDown :: Int
scrollDown = Int
65

hasBitSet :: Int -> Int -> Bool
hasBitSet :: Int -> Int -> Bool
hasBitSet Int
val 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
> Int
0

-- | Attempt to lassify an input string as a mouse event.
classifyMouseEvent :: String -> KClass
classifyMouseEvent :: String -> KClass
classifyMouseEvent 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 Char
'\ESC'
    Char -> MaybeT (State String) ()
expectChar Char
'['
    Char
ty <- Parser Char
readChar
    case Char
ty of
        Char
'<' -> Parser Event
classifySGRMouseEvent
        Char
'M' -> Parser Event
classifyNormalMouseEvent
        Char
_   -> Parser Event
forall a. Parser a
failParse

-- Given a modifer/button value, determine which button was indicated
getSGRButton :: Int -> Parser Button
getSGRButton :: Int -> Parser Button
getSGRButton 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
        Maybe Button
Nothing -> Parser Button
forall a. Parser a
failParse
        Just Button
b -> Button -> Parser Button
forall (m :: * -> *) a. Monad m => a -> m a
return Button
b

getModifiers :: Int -> [Modifier]
getModifiers :: Int -> [Modifier]
getModifiers 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
              ]

-- Attempt to classify a control sequence as a "normal" mouse event. To
-- get here we should have already read "\ESC[M" so that will not be
-- included in the string to be parsed.
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
- Int
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
- Int
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
/= Int
3
    case Bool
press of
            Bool
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
-Int
1) (Int
yCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Button
button [Modifier]
modifiers
            Bool
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
-Int
1) (Int
yCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Maybe Button
forall a. Maybe a
Nothing

-- Attempt to classify a control sequence as an SGR mouse event. To
-- get here we should have already read "\ESC[<" so that will not be
-- included in the string to be parsed.
classifySGRMouseEvent :: Parser Event
classifySGRMouseEvent :: Parser Event
classifySGRMouseEvent = do
    Int
mods <- Parser Int
readInt
    Char -> MaybeT (State String) ()
expectChar Char
';'
    Int
xCoord <- Parser Int
readInt
    Char -> MaybeT (State String) ()
expectChar Char
';'
    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
        Char
'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
-Int
1) (Int
yCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Button
button [Modifier]
modifiers
        Char
'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
-Int
1) (Int
yCoordInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Button -> Maybe Button
forall a. a -> Maybe a
Just Button
button)
        Char
_ -> Parser Event
forall a. Parser a
failParse