diff options
| -rw-r--r-- | jterm.hs | 76 |
1 files changed, 41 insertions, 35 deletions
@@ -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)) |