add VT200 mouse support

3 files changed, 98 insertions, 21 deletions

diff --git a/Event.hs b/Event.hs
index a0d43b7..f316c13 100644
--- a/Event.hs
+++ b/Event.hs
@@ -1,6 +1,4 @@
-module Event
-    ( Event (..)
-    ) where
+module Event where
 
 import Trammel
 
@@ -8,7 +6,18 @@ import Trammel
 data Event =
     EFlash (Trammel String) |
     EKey String |
-    EMouse Char Int Int | -- TODO s/Char/..
+    EMouse MouseInfo |
     EReload |
     EResize Int Int
   deriving Show
+
+
+data MouseInfo = MouseInfo
+    { mouseButton :: Int -- 0 = release
+    , mouseShift :: Bool
+    , mouseMeta :: Bool
+    , mouseControl :: Bool
+    , mouseX :: Int
+    , mouseY :: Int
+    }
+  deriving Show
diff --git a/Scanner.hs b/Scanner.hs
index 361a1c6..df48868 100644
--- a/Scanner.hs
+++ b/Scanner.hs
@@ -4,7 +4,9 @@ module Scanner
     ( scan
     ) where
 
+import Data.Bits ((.&.), testBit)
 import Data.Char (ord)
+import Data.Word (Word8)
 import Event
 import System.IO (Handle, hGetChar, hLookAhead, hWaitForInput)
 
@@ -48,12 +50,11 @@ scanCS h =
         Nothing -> return $ EKey "\ESC" -- TODO move this to scanESC
         Just c
             | c == 'M' -> do
-                -- VT200 mouse
                 _ <- hGetChar h -- drop 'M'
                 b <- hGetChar h
                 x <- hGetChar h
                 y <- hGetChar h
-                return $ EMouse b (ord x - 32) (ord y - 32)
+                return $ parseNormalButton b x y
             | otherwise ->
                 zeroOrMore h parameterByte ['[', '\ESC'] >>=
                 zeroOrMore h intermediateByte >>=
@@ -113,3 +114,28 @@ hWaitLookAhead t h = do
     if ready
         then hLookAhead h >>= return . Just
         else return Nothing
+
+
+parseNormalButton :: Char -> Char -> Char -> Event
+parseNormalButton cb cx cy = do
+    let b = fromIntegral $ ord cb :: Word8
+        x = ord cx - 32
+        y = ord cy - 32
+        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"
+    EMouse $ MouseInfo
+        { mouseButton  = button
+        , mouseShift   = testBit b 2
+        , mouseMeta    = testBit b 3
+        , mouseControl = testBit b 4
+        , mouseX       = x
+        , mouseY       = y
+        }
diff --git a/test5.hs b/test5.hs
index 5448470..d8eb0b5 100644
--- a/test5.hs
+++ b/test5.hs
@@ -16,6 +16,7 @@ import Control.Applicative
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
+import Data.List (intercalate)
 import Data.Maybe
 import Data.Monoid
 import Data.Time
@@ -68,33 +69,41 @@ initState = do
 
 
 main :: IO ()
-main = finally startup cleanup
+main =
+    finally (startup decset decrst)
+            (cleanup decset decrst)
+  where
+    decset =
+        1000 : -- X & Y on button press and release
+        1005 : -- UTF-8 mouse mode
+        1049 : -- use cleared alternate screen buffer
+        []
+    decrst =
+        25 : -- hide cursor
+        []
 
 
-cleanup :: IO ()
-cleanup = do
-    hPutStr stdout "\ESC[?25h"
-    hPutStr stdout "\ESC[?1049l"
+cleanup :: [Int] -> [Int] -> IO ()
+cleanup decset decrst = do
+    hSetEcho stdin True
+    hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decset) ++ "l"
+    hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decrst) ++ "h"
 
 
-startup :: IO ()
-startup = do
+startup :: [Int] -> [Int] -> IO ()
+startup decset decrst = do
 
     -- load-env hack
     maybe (return ()) (setEnv "HOME") =<< lookupEnv "OLDHOME"
 
-    hSetEcho stdin False
     hSetBuffering stdin NoBuffering
     hSetBuffering stdout (BlockBuffering $ Just 4096)
 
-    q0@State{..} <- initState
+    hSetEcho stdin False
+    hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decset) ++ "h"
+    hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decrst) ++ "l"
 
-    --hSetEcho stdin False
-    --hSetBuffering stdin NoBuffering
-    -- Save Cursor and use Alternate Screen Buffer
-    hPutStr stdout "\ESC[?1049h"
-    -- Hide Cursor
-    hPutStr stdout "\ESC[?25l"
+    q0@State{..} <- initState
 
     (putEvent, getEvent) <- do
         v <- newEmptyMVar
@@ -138,6 +147,7 @@ run getEvent = rec where
         redraw q' >> getEvent >>= processEvent q'
 
 
+-- TODO merge EKey and EMouse?
 processEvent :: State -> Event -> IO State
 processEvent q = \case
     EFlash t ->
@@ -148,6 +158,12 @@ processEvent q = \case
                 a q
             Nothing ->
                 return q { flashMessage = Plain $ show s }
+    EMouse info ->
+        case mousemap info of
+            Just a ->
+                a q
+            Nothing ->
+                return q { flashMessage = SGR [38,5,202] $ Plain $ show info }
     EResize w h ->
         return q
             { screenWidth = w, screenHeight = h
@@ -225,6 +241,32 @@ keymap "\ESC[>85;95;0c" = Just $ \q -> return q { flashMessage = flashMessage q
 keymap _ = Nothing
 
 
+mousemap :: MouseInfo -> Maybe (State -> IO State)
+
+mousemap MouseInfo{mouseButton=4} = Just $ moveTreeDown 3
+mousemap MouseInfo{mouseButton=5} = Just $ moveTreeUp 3
+
+mousemap MouseInfo{mouseButton=1,mouseY=y} = Just $ \q@State{..} -> do
+    let linearClickPos =
+            let i = (y - length headBuffer + yoffset) - 1 {-zero-based-}
+            in if 0 <= i && i < length treeBuffer
+                then Just i
+                else Nothing
+    case linearClickPos of
+        Nothing ->
+            return q
+                { flashMessage = Plain $ "nothing to click"
+                }
+        Just i ->
+            return q
+                { cursor = findNextN i $ Z.root cursor
+                }
+
+mousemap MouseInfo{mouseButton=0} = Just return
+
+mousemap _ = Nothing
+
+
 
 topOverrun :: State -> Int
 topOverrun State{..} =