summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--jterm.hs76
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))