diff options
| -rw-r--r-- | Event.hs | 17 | ||||
| -rw-r--r-- | Scanner.hs | 30 | ||||
| -rw-r--r-- | test5.hs | 72 |
3 files changed, 98 insertions, 21 deletions
@@ -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 @@ -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 + } @@ -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{..} = |