summaryrefslogtreecommitdiff
path: root/jterm.hs
diff options
context:
space:
mode:
Diffstat (limited to 'jterm.hs')
-rw-r--r--jterm.hs64
1 files changed, 38 insertions, 26 deletions
diff --git a/jterm.hs b/jterm.hs
index 2b49a2a..98ac2ba 100644
--- a/jterm.hs
+++ b/jterm.hs
@@ -1,7 +1,8 @@
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StrictData #-}
+{-# LANGUAGE ViewPatterns #-}
import Control.Concurrent
import Control.Exception
@@ -20,6 +21,7 @@ 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 Data.Word (Word64)
import Foreign.C.String
import Foreign.C.Types
import GHC.IO.Encoding
@@ -34,14 +36,17 @@ import System.Environment
import System.IO.Unsafe
import System.Posix.Pty
+doubleClickDelay :: Time
doubleClickDelay = 300
+(-.) :: (Ord a, Num a) => a -> a -> a
a -. b
| b > a = 0
| otherwise = a - b
infixl 1 -.
+memo :: (Ord k) => (k -> a) -> k -> a
memo f = unsafePerformIO $ do
mvar <- newMVar M.empty
pure $ \x -> unsafePerformIO $ do
@@ -64,7 +69,7 @@ data Buffer = Buffer
}
search :: Rope -> Rope -> Word -> Maybe Word
-search needle haystack p = go (n - 1) p
+search needle haystack = go (n - 1)
where
index rope i = R.splitAt (i + 1) rope & fst & R.splitAt i & snd
go i j
@@ -80,7 +85,7 @@ search needle haystack p = go (n - 1) p
n = R.length needle
bsearch :: Rope -> Rope -> Word -> Maybe Word
-bsearch needle haystack p = go 0 p
+bsearch needle haystack = go 0
where
index rope i = R.splitAt (i + 1) rope & fst & R.splitAt i & snd
go i j
@@ -122,6 +127,7 @@ expandAround rp p =
| i < l = let (R.splitAt (i - 1) -> (_, sel), _) = R.splitAt i rp in R.toText sel
getc _ = ""
+ searchFor :: Bool -> Int -> (Text -> Bool) -> (Text -> Bool) -> Word -> Word
searchFor fwd n a b p =
case getc p of
"" -> if fwd then p - 1 else p
@@ -130,6 +136,7 @@ expandAround rp p =
then if fwd then p - 1 else p
else searchFor fwd (n + if a c then 1 else if b c then -1 else 0) a b (if fwd then p + 1 else p - 1)
+drawWin :: Display -> Drawable -> XftColor -> XftColor -> XftColor -> XftColor -> XftFont -> StateT Buffer IO ()
drawWin display win bgcolour fgcolour linecolour selcolour font = do
buf <- get
lift $ do
@@ -138,7 +145,7 @@ drawWin display win bgcolour fgcolour linecolour selcolour font = do
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
- xftDrawRect draw bgcolour 0 0 n m
+ xftDrawRect draw bgcolour (0 :: Int) (0 :: Int) n m
-- Get rope covering window area
let winlines = fromIntegral m `div` fromIntegral height
@@ -153,12 +160,13 @@ drawWin display win bgcolour fgcolour linecolour selcolour font = do
Position l1 c1 = R.lengthAsPosition presel
Position l2 c2 = R.lengthAsPosition (presel <> sel)
- xftDrawRect draw linecolour 0 (l1 * fromIntegral height + 4) n height
+ xftDrawRect draw linecolour (0 :: Int) (l1 * fromIntegral height + 4) n height
drawRope False draw fgcolour bgcolour 0 height (R.lines presel)
drawRope True draw fgcolour selcolour (fromIntegral c1 * width) (fromIntegral (l1 + 1) * height) (R.lines sel)
drawRope False draw fgcolour bgcolour (fromIntegral c2 * width) (fromIntegral (l2 + 1) * height) (R.lines postsel)
copyArea display p win gc 0 0 n m 0 0
where
+ drawRope :: Bool -> XftDraw -> XftColor -> XftColor -> Int -> Int -> [Text] -> IO ()
drawRope _ _ _ _ _ _ [] = pure ()
drawRope drawbg draw fgcolour bgcolour x y (l : ls) = do
when drawbg $ xftDrawRect draw bgcolour x (y - height + 4) (width * T.length l) height
@@ -174,6 +182,7 @@ fontSize display font = unsafePerformIO $ do
height <- xftfont_height font
pure (height, xglyphinfo_xOff extents)
+key :: CUInt -> Word64 -> Rope
key mod k = case (mod, k) of
(_, 32) -> " "
(0, 39) -> "'"
@@ -322,7 +331,7 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do
case search selstr (content b) (1 + end) of
Just p -> do
(_, _, _, _, m, _, _) <- lift $ getGeometry display win
- let (height, width) = fontSize display font
+ let (height, _) = fontSize display font
pageheight = fromIntegral m `div` fromIntegral height
put $ b {cursor = (p, p + end - start), pos = max (pos b) $ R.lengthInLines (R.splitAt p (content b) & fst) + 1 -. pageheight}
Nothing -> pure ()
@@ -395,12 +404,12 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do
(_, 65364) -> scrolldown 1
(_, 65365) -> do
(_, _, _, _, m, _, _) <- lift $ getGeometry display win
- let (height, width) = fontSize display font
+ let (height, _) = fontSize display font
pageheight = fromIntegral m `div` fromIntegral height
scrollup ((681 * pageheight) `div` 1000)
(_, 65366) -> do
(_, _, _, _, m, _, _) <- lift $ getGeometry display win
- let (height, width) = fontSize display font
+ let (height, _) = fontSize display font
pageheight = fromIntegral m `div` fromIntegral height
scrolldown ((681 * pageheight) `div` 1000)
(_, 65288) -> do
@@ -408,7 +417,7 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do
delins (start - 1) end ""
_ -> when (toAppend /= "") $ do
delins start end toAppend
- when (toAppend == "\n" && start == R.length (content b)) $ sendline
+ when (toAppend == "\n" && start == R.length (content b)) sendline
redraw
T toAppend -> do
let noesc = stripAnsiEscapeCodes toAppend
@@ -417,9 +426,11 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do
redraw
Notify -> do
prop <- lift $ internAtom display "JTERM_CLIPBOARD" False
- Just (R.fromText . T.pack . map castCCharToChar -> str) <- lift $ getWindowProperty8 display prop win
- delins start end str
- redraw
+ lift (getWindowProperty8 display prop win) >>= \case
+ Just (R.fromText . T.pack . map castCCharToChar -> str) -> do
+ delins start end str
+ redraw
+ _ -> pure ()
Expose -> redraw
Selection e -> lift $ allocaXEvent $ \ev -> do
setEventType ev selectionNotify
@@ -439,7 +450,7 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do
b <- get
let cmd = between (ptycursor b) (R.length $ content b) (content b)
put $ b {ptycursor = R.length (content b)}
- lift $ send b $ cmd
+ lift $ send b cmd
sendCommand b c = do
attrs <- getTerminalAttributes (pty b)
@@ -450,28 +461,29 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do
lift $ sync display False
between s e rp = R.splitAt e rp & fst & R.splitAt s & snd
-
+
delins = delins' False
-
+
delins' movepty s e ins = do
b <- get
let l = R.length ins
p = ptycursor b
- p' = if e < p then p + l + s - e
- else if s < p then s
- else p
+ p'
+ | e < p = p + l + s - e
+ | s < p = s
+ | otherwise = p
(cs, ce) = cursor b
- c' = if cs <= e && ce > e then (s + l, ce)
- else if cs < s && ce >= s then (cs, s)
- else if cs >= s && ce <= e then (s + l, s + l)
- else if ce < s then (cs, ce)
- else (cs + l + s - e, ce + l + s - e)
+ c'
+ | cs <= e && ce > e = (s + l, ce)
+ | cs < s && ce >= s = (cs, s)
+ | cs >= s && ce <= e = (s + l, s + l)
+ | ce < s = (cs, ce)
+ | otherwise = (cs + l + s - e, ce + l + s - e)
put $ b {content = doedit s e (content b) ins, cursor = c', ptycursor = if movepty then s + l else p'}
-
where
doedit s e rp ins =
- let (before, _) = R.splitAt s rp
- (_, after) = R.splitAt e rp
+ let (before, _) = R.splitAt s rp
+ (_, after) = R.splitAt e rp
in before <> ins <> after
xy2lc :: Word -> Word -> IO (Word, Word)
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-01 10:23:02 +0000