diff options
| -rw-r--r-- | jterm.hs | 64 |
1 files changed, 38 insertions, 26 deletions
@@ -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) |