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.

1 files 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))