From 83d02e27ac3a4b87761fa9bd79520aa3161b8b91 Mon Sep 17 00:00:00 2001 From: Justin Bedo Date: Thu, 10 Oct 2024 09:52:43 +1100 Subject: initial prototype --- flake.lock | 26 ++++ flake.nix | 10 ++ jterm.hs | 416 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ package.yaml | 26 ++++ 4 files changed, 478 insertions(+) create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 jterm.hs create mode 100644 package.yaml diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..5426671 --- /dev/null +++ b/flake.lock @@ -0,0 +1,26 @@ +{ + "nodes": { + "nixpkgs": { + "locked": { + "lastModified": 1728512251, + "narHash": "sha256-VLFbv8u9CJGe3c0/MsKbG/JPU4mP1/uiDl4ttMMx5Oc=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "2792ebe30b4ef8d86b27891553a0a1160d69d11f", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..fec219d --- /dev/null +++ b/flake.nix @@ -0,0 +1,10 @@ +{ + inputs.nixpkgs.url = "github:nixos/nixpkgs"; + outputs = {self, nixpkgs}: + let + system = "x86_64-linux"; + pkgs = import nixpkgs {inherit system;}; + in { + packages.${system}.default = pkgs.haskellPackages.callCabal2nix "jterm" ./. {}; + }; +} diff --git a/jterm.hs b/jterm.hs new file mode 100644 index 0000000..7f98e99 --- /dev/null +++ b/jterm.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +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 Data.Function +import Data.Maybe +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.Types +import Graphics.X11.Types +import Graphics.X11.Xft +import Graphics.X11.Xlib hiding (Buffer, Position) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xrender +import qualified Streamly.Data.Fold as F +import qualified Streamly.Data.Stream.Prelude as S +import System.Environment +import System.IO.Unsafe +import System.Process + +data Buffer = Buffer + { pos :: Word, + content :: Rope, + cursor :: (Word, Word), + selection :: Maybe (CInt, CInt), + pty :: Pty + } + +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) + 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 + + -- Get rope covering window area + let winlines = fromIntegral m `div` fromIntegral height + let (pre, R.splitAtLine winlines -> (vis, _)) = R.splitAtLine (pos buf) (content buf) + + -- relative cursor position + let (s, e) = cursor buf + s' :: Int = fromIntegral s - fromIntegral (R.length pre) + e' :: Int = fromIntegral (max e $ s + 1) - fromIntegral (R.length pre) + + let (R.splitAt (fromIntegral $ max 0 s') -> (presel, sel), postsel) = R.splitAt (fromIntegral $ max 0 e') vis + Position l1 c1 = R.lengthAsPosition presel + Position l2 c2 = R.lengthAsPosition (presel <> sel) + + xftDrawRect draw linecolour 0 (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 _ _ _ _ _ _ [] = 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 + xftDrawString draw fgcolour font x y (T.unpack l) + drawRope drawbg draw fgcolour bgcolour 0 (y + height) ls + + (height, width) = fontSize display font + +-- assume fixed width fonts +fontSize :: Display -> XftFont -> (Int, Int) +fontSize display font = unsafePerformIO $ do + extents <- xftTextExtents display font "a" + height <- xftfont_height font + pure (height, xglyphinfo_xOff extents) + +key mod k = case (mod, k) of + (_, 32) -> " " + (0, 39) -> "'" + (0, 44) -> "," + (0, 45) -> "-" + (0, 46) -> "." + (0, 47) -> "/" + (0, 48) -> "0" + (0, 49) -> "1" + (0, 50) -> "2" + (0, 51) -> "3" + (0, 52) -> "4" + (0, 53) -> "5" + (0, 54) -> "6" + (0, 55) -> "7" + (0, 56) -> "8" + (0, 57) -> "9" + (0, 59) -> ";" + (0, 61) -> "=" + (0, 91) -> "[" + (0, 92) -> "\\" + (0, 93) -> "]" + (0, 96) -> "`" + (0, 97) -> "a" + (0, 98) -> "b" + (0, 99) -> "c" + (0, 100) -> "d" + (0, 101) -> "e" + (0, 102) -> "f" + (0, 103) -> "g" + (0, 104) -> "h" + (0, 105) -> "i" + (0, 106) -> "j" + (0, 107) -> "k" + (0, 108) -> "l" + (0, 109) -> "m" + (0, 110) -> "n" + (0, 111) -> "o" + (0, 112) -> "p" + (0, 113) -> "q" + (0, 114) -> "r" + (0, 115) -> "s" + (0, 116) -> "t" + (0, 117) -> "u" + (0, 118) -> "v" + (0, 119) -> "w" + (0, 120) -> "x" + (0, 121) -> "y" + (0, 122) -> "z" + (1, 39) -> "\"" + (1, 44) -> "<" + (1, 45) -> "_" + (1, 46) -> ">" + (1, 47) -> "?" + (1, 48) -> ")" + (1, 49) -> "!" + (1, 50) -> "@" + (1, 51) -> "#" + (1, 52) -> "$" + (1, 53) -> "%" + (1, 54) -> "^" + (1, 55) -> "&" + (1, 56) -> "*" + (1, 57) -> "(" + (1, 59) -> ":" + (1, 61) -> "+" + (1, 91) -> "{" + (1, 92) -> "|" + (1, 93) -> "}" + (1, 96) -> "~" + (1, 97) -> "A" + (1, 98) -> "B" + (1, 99) -> "C" + (1, 100) -> "D" + (1, 101) -> "E" + (1, 102) -> "F" + (1, 103) -> "G" + (1, 104) -> "H" + (1, 105) -> "I" + (1, 106) -> "J" + (1, 107) -> "K" + (1, 108) -> "L" + (1, 109) -> "M" + (1, 110) -> "N" + (1, 111) -> "O" + (1, 112) -> "P" + (1, 113) -> "Q" + (1, 114) -> "R" + (1, 115) -> "S" + (1, 116) -> "T" + (1, 117) -> "U" + (1, 118) -> "V" + (1, 119) -> "W" + (1, 120) -> "X" + (1, 121) -> "Y" + (1, 122) -> "Z" + (_, 65289) -> "\t" + (_, 65293) -> "\n" + _ -> "" + +data HandledEvent = GraphicsExpose | NoExpose | Expose | Key XKeyEvent | T Text | Selection Event | Notify + +waitEvent :: Display -> XEventPtr -> IO HandledEvent +waitEvent display event = do + nextEvent display event + ty <- get_EventType event + if ty == expose + then + pure Expose + else + if ty == graphicsExpose + then + pure GraphicsExpose + else + if ty == noExpose + then + pure NoExpose + else + if ty == selectionRequest + then + Selection <$> getEvent event + else + if ty == selectionNotify + then + pure Notify + else do + ev <- get_KeyEvent event + pure $ Key ev + +handleEvent :: Display -> Drawable -> XftColor -> XftColor -> XftColor -> XftColor -> XftFont -> HandledEvent -> StateT Buffer IO () +handleEvent display win bgcolour fgcolour linecolour selcolour font event = do + b <- get + let (start, end) = cursor b + case event of + Key (_, _, time, x, y, _, _, mod, keycode, _) -> do + keysym <- lift $ keycodeToKeysym display keycode 0 + let toAppend = key mod keysym + case (mod, keycode) of -- handle buttons + (0, 1) -> do + -- left click down + p <- lift $ getPos x y b + put $ b {cursor = (p, p), selection = Just (x, y)} + (_, 1) -> + -- left click up + put $ b {selection = Nothing} + (0, 4) -> scrollup 3 -- scroll wheel + (0, 5) -> scrolldown 3 + _ -> + case selection b of + Just (max 0 -> x0, max 0 -> y0) -> do + p <- lift $ getPos x0 y0 b + q <- lift $ getPos x y b + put $ b {cursor = (min p q, max p q)} + _ -> do + case (mod, keysym) of + (4, 99) -> lift $ do + -- ctrl-c (copy) + let (R.splitAt start -> (_, sel), _) = R.splitAt end (content b) + storeBuffer display (R.toText sel & T.unpack) 0 + xSetSelectionOwner display pRIMARY win time + xSetSelectionOwner display sECONDARY win time + (4, 120) -> do + -- ctrl-x (cut) + let (R.splitAt start -> (_, sel), _) = R.splitAt end (content b) + lift $ storeBuffer display (R.toText sel & T.unpack) 0 + put $ b {content = delins start end (content b) "", cursor = (start + 1, start + 1)} + (4, 118) -> lift $ do + -- ctrl-v (paste) + -- win <- xGetSelectionOwner display pRIMARY + prop <- internAtom display "JTERM_CLIPBOARD" True + xConvertSelection display pRIMARY xUtf8String prop win time + (4, 113) -> lift $ do + -- ctrl-q (write log) + home <- getEnv "HOME" + T.writeFile (home <> "/jterm.log") (R.toText (content b)) + (4, 115) -> do + -- ctrl-s (send) + let (R.splitAt start -> (_, sel), _) = R.splitAt end (content b) + lift $ send b (sel <> "\n") + (_, 65361) -> do + -- left + let s = start - min start 1 + put $ b {cursor = (s, s)} + (_, 65363) -> do + -- right + let e = min (R.length (content b)) $ end + 1 + put $ b {cursor = (e, e)} + (_, 65535) -> lift $ sendCommand b Interrupt + (_, 65360) -> put $ b {pos = 0} -- home + (_, 65367) -> do + -- end + let e = R.length (content b) + put $ b {cursor = (e, e)} + scrolldown (maxBound - pos b) + (_, 65362) -> scrollup 1 + (_, 65364) -> scrolldown 1 + (_, 65365) -> do + (_, _, _, _, m, _, _) <- lift $ getGeometry display win + let (height, width) = 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 + pageheight = fromIntegral m `div` fromIntegral height + scrolldown ((681 * pageheight) `div` 1000) + (_, 65288) -> 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 (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)} + 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)} + 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 + Expose -> redraw + Selection e -> lift $ allocaXEvent $ \ev -> do + setEventType ev selectionNotify + if ev_target e == xUtf8String + then do + clip <- fetchBuffer display 0 + changeProperty8 display (ev_requestor e) (ev_property e) (ev_target e) propModeReplace (map (fromIntegral . fromEnum) clip) + setSelectionNotify ev (ev_requestor e) (ev_selection e) (ev_target e) (ev_property e) (ev_time e) + else setSelectionNotify ev (ev_requestor e) (ev_selection e) (ev_target e) 0 (ev_time e) + sendEvent display (ev_requestor e) False noEventMask ev + flush display + _ -> pure () + where + xUtf8String = 315 :: Atom + + sendCommand b c = do + attrs <- getTerminalAttributes (pty b) + writePty (pty b) (B.fromString [fromJust $ controlChar attrs c]) + + redraw = do + drawWin display win bgcolour fgcolour linecolour selcolour font + lift $ sync display False + + delins :: Word -> Word -> Rope -> Rope -> Rope + delins s e rp ins = + let (before, _) = R.splitAt s rp + (_, after) = R.splitAt e rp + in before <> ins <> after + + xy2lc :: Word -> Word -> IO (Word, Word) + xy2lc x y = do + let (height, width) = fontSize display font + let c = x `div` fromIntegral width + l = y `div` fromIntegral height + pure (l, c) + + lc2pos :: Word -> Word -> Rope -> Word + lc2pos l c rp = + let p = R.splitAtPosition (Position l c) rp & fst & R.length + pmax = R.splitAtLine (1 + l) rp & fst & R.length + in min p pmax + + getPos :: CInt -> CInt -> Buffer -> IO Word + getPos x y b = do + (l, c) <- xy2lc (max 0 $ fromIntegral x) (max 0 $ fromIntegral y) + let p = lc2pos (pos b + l) c (content b) + pure p + + scrollup k = modify $ \b -> b {pos = pos b - min (pos b) k} + scrolldown k = modify $ \b -> b {pos = min (R.lengthInLines (content b) - 1) (pos b + k)} + + send b cmd = writePty (pty b) (R.toText cmd & T.unpack & B.fromString) + + expandTabs = go . T.splitOn "\t" + where + 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 +watch h = T . T.filter (/= '\r') . T.pack . B.toString <$> readPty h + +main :: IO () +main = do + setLocaleEncoding utf8 + env <- getEnvironment + 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 + let screenno = defaultScreen display + border = blackPixel display screenno + background = whitePixel display screenno + screen = defaultScreenOfDisplay display + visual = defaultVisualOfScreen screen + colourmap = defaultColormap display screenno + font <- xftFontOpen display screen "Iosevka Extended:size=12" + rootw <- rootWindow display screenno + 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)) diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..01842b5 --- /dev/null +++ b/package.yaml @@ -0,0 +1,26 @@ +name: jterm +version: 0.1 + +dependencies: + - base + - streamly-core + - streamly + - process + - X11 + - X11-xft + - text-rope + - posix-pty + - unix + - text + - utf8-string + - bytestring + - mtl + - transformers + - strip-ansi-escape + - fusion-plugin + +ghc-options: [-O2, -fdicts-strict, -fspec-constr-recursive=16, -fmax-worker-args=16, -fplugin=Fusion.Plugin, -Wall, -Wno-name-shadowing, -threaded, -with-rtsopts=--nonmoving-gc] + +executables: + jterm: + main: jterm.hs -- cgit v1.2.3