admit SGR mouse protocolHEADmaster

1 files changed, 68 insertions, 28 deletions

diff --git a/src/Scanner.hs b/src/Scanner.hs
index f971727..44bc1fc 100644
--- a/src/Scanner.hs
+++ b/src/Scanner.hs
@@ -7,7 +7,6 @@ module Scanner
 
 import Data.Bits ((.&.), testBit)
 import Data.Char (ord)
-import Data.Word (Word8)
 import System.IO (Handle, hGetChar, hLookAhead, hWaitForInput)
 
 
@@ -17,10 +16,12 @@ timeout = 1
 data Scan =
     ScanKey String
   | ScanMouse
-      { mouseButton :: Int -- 0 = release
+      { mouseButton :: Int
+      , mousePressed :: Bool -- True == pressed, False == released
       , mouseShift :: Bool
       , mouseMeta :: Bool
       , mouseControl :: Bool
+      , mouseMotion :: Bool
       , mouseX :: Int
       , mouseY :: Int
       }
@@ -62,17 +63,51 @@ scanCS h =
     hWaitLookAhead timeout h >>= \case
         Nothing -> return $ ScanKey "\ESC" -- TODO move this to scanESC
         Just c
-            | c == 'M' -> do
-                _ <- hGetChar h -- drop 'M'
-                b <- hGetChar h
-                x <- hGetChar h
-                y <- hGetChar h
-                return $ parseNormalButton b x y
-            | otherwise ->
-                zeroOrMore h parameterByte ['[', '\ESC'] >>=
-                zeroOrMore h intermediateByte >>=
-                one h finalByte >>=
-                return . ScanKey . reverse
+          | c == '<' -> hGetChar h >> scanSGRMousePayload h
+          | c == 'M' -> hGetChar h >> scanX10MousePayload h
+          | otherwise -> scanOtherCSISequence h
+
+
+scanX10MousePayload :: Handle -> IO Scan
+scanX10MousePayload h = do
+    b <- ord <$> hGetChar h
+    x <- ord <$> hGetChar h
+    y <- ord <$> hGetChar h
+    let pressed = (b .&. 3) /= 3
+    return (decodeMouseEvent (b - 32) (x - 32) (y - 32) pressed)
+
+
+scanSGRMousePayload :: Handle -> IO Scan
+scanSGRMousePayload h = do
+    b <- scanNumber h
+    _ <- expectChar h (==';')
+    x <- scanNumber h
+    _ <- expectChar h (==';')
+    y <- scanNumber h
+    m <- hGetChar h -- 'M' or 'm'
+    let pressed = (m == 'M')
+    return (decodeMouseEvent b x y pressed)
+
+
+scanOtherCSISequence :: Handle -> IO Scan
+scanOtherCSISequence h = do
+    params <- zeroOrMore h parameterByte ['[', '\ESC']
+    inters <- zeroOrMore h intermediateByte params
+    final <- expectChar h finalByte
+    return (ScanKey (reverse (final : inters)))
+
+
+scanNumber :: Handle -> IO Int
+scanNumber h = go 0
+  where
+    go acc =
+        hWaitLookAhead timeout h >>= \case
+          Just c ->
+            if '0' <= c && c <= '9'
+              then hGetChar h >> go (acc * 10 + (ord c - ord '0'))
+              else return acc
+
+          Nothing -> fail "timeout"
 
 
 
@@ -89,14 +124,18 @@ zeroOrMore h p buf =
 
 one :: Handle -> (Char -> Bool) -> [Char] -> IO [Char]
 one h p buf =
-    hWaitLookAhead timeout h >>= \case
-        Nothing -> return buf -- TODO error?
-        Just c
-            | p c -> do
-                _ <- hGetChar h -- drop c
-                return (c:buf)
-            | otherwise ->
-                error "expected one TODO"
+    expectChar h p >>= \c -> return (c : buf)
+
+
+expectChar :: Handle -> (Char -> Bool) -> IO Char
+expectChar h p =
+    hWaitGetChar timeout h >>= \case
+      Just c ->
+        if p c
+          then return c
+          else fail ("unexpected char: " ++ show c)
+      Nothing ->
+        fail "timeout"
 
 
 parameterByte :: Char -> Bool
@@ -129,26 +168,27 @@ hWaitLookAhead t h = do
         else return Nothing
 
 
-parseNormalButton :: Char -> Char -> Char -> Scan
-parseNormalButton cb cx cy = do
-    let b = fromIntegral $ ord cb :: Word8
-        x = ord cx - 32
-        y = ord cy - 32
+decodeMouseEvent :: Int -> Int -> Int -> Bool -> Scan
+decodeMouseEvent b x y pressed =
+    let
         button = case (b .&. 3) + (b .&. 64) of
                 0 -> 1
                 1 -> 2
                 2 -> 3
-                3 -> 0 -- release
                 64 -> 4 -- wheel up
                 65 -> 5 -- wheel down
                 66 -> 6 -- wheel left
                 67 -> 7 -- wheel right
-                _ -> error "TODO proper parseNormalButton error"
+                3  -> 0 -- X10 release
+                btn -> error $ "TODO proper parseNormalButton error: " ++ show btn
+    in
     ScanMouse
         { mouseButton  = button
+        , mousePressed = pressed
         , mouseShift   = testBit b 2
         , mouseMeta    = testBit b 3
         , mouseControl = testBit b 4
+        , mouseMotion  = testBit b 5
         , mouseX       = x
         , mouseY       = y
         }