From 4da12b53ddb999d6fa4200451a335a1cf1f42547 Mon Sep 17 00:00:00 2001 From: Justin Bedo Date: Wed, 30 Oct 2024 12:37:59 +1100 Subject: switch to managing cmd line on terminal side Though this means tab completion doesn't work, it makes it much nicer to edit the current command line and also avoids lag on remote terminals. --- jterm.hs | 76 ++++++++++++++++++++++++++++++++++------------------------------ 1 file changed, 41 insertions(+), 35 deletions(-) diff --git a/jterm.hs b/jterm.hs index d11a965..812f085 100644 --- a/jterm.hs +++ b/jterm.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StrictData #-} import Control.Concurrent import Control.Exception @@ -10,6 +11,7 @@ import Control.Monad.Trans.State import Data.Bits import qualified Data.ByteString.UTF8 as B import Data.Function +import Data.Functor import qualified Data.Map as M import Data.Maybe import Data.String.AnsiEscapeCodes.Strip.Text @@ -18,7 +20,6 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Text.Rope (Position (..), Rope) import qualified Data.Text.Rope as R -import Debug.Trace import Foreign.C.String import Foreign.C.Types import GHC.IO.Encoding @@ -38,6 +39,7 @@ doubleClickDelay = 300 a -. b | b > a = 0 | otherwise = a - b + infixl 1 -. memo f = unsafePerformIO $ do @@ -55,6 +57,7 @@ data Buffer = Buffer { pos :: Word, content :: Rope, cursor :: (Word, Word), + ptycursor :: Word, selection :: Maybe (CInt, CInt), pty :: Pty, lastLeftClick :: Time @@ -341,13 +344,13 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do case (mod, keysym) of (4, 117) -> -- ctrl-u (delete content before cursor) - put $ b {content = R.splitAt start (content b) & snd, cursor = (0, end-start), pos = 0} + delins' 0 start "" (4, 105) -> -- ctrl-i (delete content after cursor) - put $ b {content = R.splitAt end (content b) & fst} + delins' end (R.length (content b)) "" (4, 108) -> -- ctrl-l (restrip buffer of ansi codes) - put $ b {content = content b & R.toText & stripAnsiEscapeCodes & R.fromText} + delins' 0 (R.length (content b)) (content b & R.toText & stripAnsiEscapeCodes & R.fromText) (4, 99) -> lift $ do -- ctrl-c (copy) storeBuffer display (R.toText selstr & T.unpack) 0 @@ -356,7 +359,7 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do (4, 120) -> do -- ctrl-x (cut) lift $ storeBuffer display (R.toText selstr & T.unpack) 0 - put $ b {content = delins start end (content b) "", cursor = (start + 1, start + 1)} + delins' start end "" (4, 118) -> lift $ do -- ctrl-v (paste) prop <- internAtom display "JTERM_CLIPBOARD" True @@ -367,7 +370,8 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do T.writeFile (home <> "/jterm.log") (R.toText (content b)) (4, 115) -> do -- ctrl-s (send) - lift $ send b (selstr <> "\n") + put $ b {content = content b <> selstr <> "\n"} + sendline (_, 65361) -> do -- left let s = start - min start 1 @@ -397,40 +401,24 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do scrolldown ((681 * pageheight) `div` 1000) (_, 65288) -> do -- backspace - let s = start -. 1 - put $ b {content = delins s end (content b) "", cursor = (s, s)} - when (start == R.length (content b)) $ lift $ sendCommand b Erase + delins' (start - 1) end "" _ -> when (toAppend /= "") $ do - if start == R.length (content b) - then lift $ send b toAppend - else put $ b {content = delins start end (content b) toAppend, cursor = (start + 1, start + 1)} + delins' start end toAppend + when (toAppend == "\n" && start >= ptycursor b) $ sendline redraw T toAppend -> do - if toAppend == "\b \b" - then -- Erase character - - let (c, _) = R.splitAt l (content b) - l = R.length (content b) - p = min start l - in put $ b {content = c, cursor = (p, p)} - else do - let c = content b <> R.fromText expandedTabs - pos = R.length c - noesc = stripAnsiEscapeCodes toAppend - expandedTabs = T.intercalate "\n" $ map expandTabs $ T.splitOn "\n" noesc - put $ b {content = c} - when (start == R.length (content b)) $ modify $ \b -> b {cursor = (pos, pos)} + let c = content b <> R.fromText expandedTabs + pos = R.length c + noesc = stripAnsiEscapeCodes toAppend + expandedTabs = T.intercalate "\n" $ map expandTabs $ T.splitOn "\n" noesc + put $ b {content = c, ptycursor = pos} + when (start == R.length (content b)) $ modify $ \b -> b {cursor = (pos, pos)} redraw Notify -> do prop <- lift $ internAtom display "JTERM_CLIPBOARD" False Just (R.fromText . T.pack . map castCCharToChar -> str) <- lift $ getWindowProperty8 display prop win - if start == R.length (content b) - then lift $ send b str - else do - let s = start + n - n = fromIntegral (R.length str) - put $ b {content = delins start end (content b) str, cursor = (s, s)} - redraw + delins' start end str + redraw Expose -> redraw Selection e -> lift $ allocaXEvent $ \ev -> do setEventType ev selectionNotify @@ -446,6 +434,11 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do where xUtf8String = 315 :: Atom + sendline = do + b <- get + let cmd = between (ptycursor b) (R.length $ content b) (content b) + lift $ send b $ cmd + sendCommand b c = do attrs <- getTerminalAttributes (pty b) writePty (pty b) (B.fromString [fromJust $ controlChar attrs c]) @@ -454,6 +447,15 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do drawWin display win bgcolour fgcolour linecolour selcolour font lift $ sync display False + between s e rp = R.splitAt e rp & fst & R.splitAt s & snd + + delins' s e ins = do + b <- get + let l = R.length ins + delta = p + l + s - e + p = ptycursor b + put $ b {content = delins s e (content b) ins, cursor = (s + l, s + l), ptycursor = if e < p then delta else if s < p then s else p} + delins :: Word -> Word -> Rope -> Rope -> Rope delins s e rp ins = let (before, _) = R.splitAt s rp @@ -498,6 +500,10 @@ main = do env <- getEnvironment let shell = case filter (\(var, _) -> var == "SHELL") env of [(_, x)] -> x; _ -> "sh" (pty, _) <- spawnWithPty (Just $ env ++ [("TERM", "dumb")]) True shell [] (80, 25) + getTerminalAttributes pty + <&> flip withoutMode EnableEcho + <&> flip withMode MapCRtoLF + >>= flip (setTerminalAttributes pty) Immediately void $ bracket (openDisplay "") closeDisplay $ \display -> do let screenno = defaultScreen display @@ -520,5 +526,5 @@ main = do withXftColorValue display visual colourmap (XRenderColor 0xaeae 0xf7f7 0xffff 0xffff) $ \linecolour -> do selectInput display win (exposureMask .|. buttonPressMask .|. buttonReleaseMask .|. keyPressMask .|. pointerMotionMask) allocaXEvent $ \e -> - flip runStateT (Buffer 0 "" (0, 0) Nothing pty 0) $ + flip runStateT (Buffer 0 "" (0, 0) 0 Nothing pty 0) $ S.parList id [S.repeatM (lift $ watch pty), S.repeatM (lift $ waitEvent display e)] & S.fold (F.drainMapM (handleEvent display win bgcolour fgcolour linecolour selcolour font)) -- cgit v1.2.3