fix pasting at end of terminal and incorrectly sending backspace

1 files changed, 47 insertions, 49 deletions

diff --git a/jterm.hs b/jterm.hs
index 7f98e99..d795554 100644
--- a/jterm.hs
+++ b/jterm.hs
@@ -1,26 +1,25 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 
 import Control.Concurrent (threadDelay)
-import Foreign.C.String
-import Data.String.AnsiEscapeCodes.Strip.Text
-import qualified Data.ByteString.UTF8 as B
-import System.Posix.Pty
-import GHC.IO.Encoding
 import Control.Exception
 import Control.Monad
 import Control.Monad.Trans
 import Control.Monad.Trans.State
 import Data.Bits
+import qualified Data.ByteString.UTF8 as B
 import Data.Function
 import Data.Maybe
+import Data.String.AnsiEscapeCodes.Strip.Text
 import Data.Text (Text)
 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 Foreign.C.String
 import Foreign.C.Types
+import GHC.IO.Encoding
 import Graphics.X11.Types
 import Graphics.X11.Xft
 import Graphics.X11.Xlib hiding (Buffer, Position)
@@ -30,6 +29,7 @@ import qualified Streamly.Data.Fold as F
 import qualified Streamly.Data.Stream.Prelude as S
 import System.Environment
 import System.IO.Unsafe
+import System.Posix.Pty
 import System.Process
 
 data Buffer = Buffer
@@ -44,7 +44,7 @@ drawWin display win bgcolour fgcolour linecolour selcolour font = do
   buf <- get
   lift $ do
     (_, _, _, n, m, _, _) <- getGeometry display win
-    resizePty (pty buf) (fromIntegral n`div`fromIntegral width, fromIntegral m`div`fromIntegral height)
+    resizePty (pty buf) (fromIntegral n `div` fromIntegral width, fromIntegral m `div` fromIntegral height)
     bracket (createGC display win) (freeGC display) $ \gc -> do
       bracket (createPixmap display win n m (defaultDepthOfScreen (defaultScreenOfDisplay display))) (freePixmap display) $ \p -> do
         withXftDraw display p (defaultVisualOfScreen (defaultScreenOfDisplay display)) (defaultColormap display 0) $ \draw -> do
@@ -191,24 +191,19 @@ waitEvent display event = do
   nextEvent display event
   ty <- get_EventType event
   if ty == expose
-    then
-      pure Expose
+    then pure Expose
     else
       if ty == graphicsExpose
-        then
-          pure GraphicsExpose
+        then pure GraphicsExpose
         else
           if ty == noExpose
-            then
-              pure NoExpose
+            then pure NoExpose
             else
               if ty == selectionRequest
-                then
-                  Selection <$> getEvent event
+                then Selection <$> getEvent event
                 else
                   if ty == selectionNotify
-                    then
-                      pure Notify
+                    then pure Notify
                     else do
                       ev <- get_KeyEvent event
                       pure $ Key ev
@@ -294,34 +289,38 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do
                   -- backspace
                   let s = if start > 0 then start - 1 else 0
                   put $ b {content = delins s end (content b) "", cursor = (s, s)}
-                  lift $ sendCommand b Erase
+                  when (start == R.length (content b)) $ lift $ sendCommand b Erase
                 _ -> 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)}
+                  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)}
       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)}
+      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)}
       redraw
     Notify -> do
       prop <- lift $ internAtom display "JTERM_CLIPBOARD" False
-      Just (T.pack . map castCCharToChar -> str) <- lift $ getWindowProperty8 display prop win
-      let s = start + n
-          n = fromIntegral (T.length str)
-      put $ b {content = delins start end (content b) (R.fromText str), cursor = (s, s)}
-      redraw
+      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
     Expose -> redraw
     Selection e -> lift $ allocaXEvent $ \ev -> do
       setEventType ev selectionNotify
@@ -338,8 +337,8 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do
     xUtf8String = 315 :: Atom
 
     sendCommand b c = do
-                  attrs <- getTerminalAttributes (pty b)
-                  writePty (pty b) (B.fromString [fromJust $ controlChar attrs c])
+      attrs <- getTerminalAttributes (pty b)
+      writePty (pty b) (B.fromString [fromJust $ controlChar attrs c])
 
     redraw = do
       drawWin display win bgcolour fgcolour linecolour selcolour font
@@ -377,7 +376,7 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do
 
     expandTabs = go . T.splitOn "\t"
       where
-        go (a:b:xs) = a <> T.pack (replicate (8-T.length a `mod` 8) ' ') <> go (b : xs)
+        go (a : b : xs) = a <> T.pack (replicate (8 - T.length a `mod` 8) ' ') <> go (b : xs)
         go x = mconcat x
 
 watch :: Pty -> IO HandledEvent
@@ -387,7 +386,7 @@ main :: IO ()
 main = do
   setLocaleEncoding utf8
   env <- getEnvironment
-  let shell = case filter (\(var,_) -> var == "SHELL") env of [(_,x)] -> x; _ -> "sh"
+  let shell = case filter (\(var, _) -> var == "SHELL") env of [(_, x)] -> x; _ -> "sh"
   (pty, _) <- spawnWithPty (Just $ env ++ [("TERM", "dumb")]) True shell [] (80, 25)
 
   void $ bracket (openDisplay "") closeDisplay $ \display -> do
@@ -402,15 +401,14 @@ main = do
     win <- createSimpleWindow display rootw 0 0 100 100 1 border background
     mapWindow display win
 
-
     -- ensure clipboard is not empty
     storeBuffer display "" 0
 
     withXftColorName display visual colourmap "black" $ \fgcolour ->
       withXftColorValue display visual colourmap (XRenderColor 0xffff 0xffff 0xeaea 0xffff) $ \bgcolour -> do
         withXftColorValue display visual colourmap (XRenderColor 0x3030 0xd4d4 0xd4d4 0xffff) $ \selcolour -> do
-         withXftColorValue display visual colourmap (XRenderColor 0xaeae 0xeeee 0xeeee 0xffff) $ \linecolour -> do
-          selectInput display win (exposureMask .|. buttonPressMask .|. buttonReleaseMask .|. keyPressMask .|. pointerMotionMask)
-          allocaXEvent $ \e ->
-            flip runStateT (Buffer 0 "" (0, 0) Nothing pty) $
-              S.parList (S.eager True) [S.repeatM (lift $ waitEvent display e), S.repeatM (lift $ watch pty)] & S.fold (F.drainMapM (handleEvent display win bgcolour fgcolour linecolour selcolour font))
+          withXftColorValue display visual colourmap (XRenderColor 0xaeae 0xeeee 0xeeee 0xffff) $ \linecolour -> do
+            selectInput display win (exposureMask .|. buttonPressMask .|. buttonReleaseMask .|. keyPressMask .|. pointerMotionMask)
+            allocaXEvent $ \e ->
+              flip runStateT (Buffer 0 "" (0, 0) Nothing pty) $
+                S.parList (S.eager True) [S.repeatM (lift $ waitEvent display e), S.repeatM (lift $ watch pty)] & S.fold (F.drainMapM (handleEvent display win bgcolour fgcolour linecolour selcolour font))