diff options
| -rw-r--r-- | jterm.hs | 96 |
1 files changed, 47 insertions, 49 deletions
@@ -1,26 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} 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 qualified Data.ByteString.UTF8 as B import Data.Function import Data.Maybe +import Data.String.AnsiEscapeCodes.Strip.Text 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.String import Foreign.C.Types +import GHC.IO.Encoding import Graphics.X11.Types import Graphics.X11.Xft import Graphics.X11.Xlib hiding (Buffer, Position) @@ -30,6 +29,7 @@ import qualified Streamly.Data.Fold as F import qualified Streamly.Data.Stream.Prelude as S import System.Environment import System.IO.Unsafe +import System.Posix.Pty import System.Process data Buffer = Buffer @@ -44,7 +44,7 @@ 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) + 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 @@ -191,24 +191,19 @@ waitEvent display event = do nextEvent display event ty <- get_EventType event if ty == expose - then - pure Expose + then pure Expose else if ty == graphicsExpose - then - pure GraphicsExpose + then pure GraphicsExpose else if ty == noExpose - then - pure NoExpose + then pure NoExpose else if ty == selectionRequest - then - Selection <$> getEvent event + then Selection <$> getEvent event else if ty == selectionNotify - then - pure Notify + then pure Notify else do ev <- get_KeyEvent event pure $ Key ev @@ -294,34 +289,38 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = 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 (start == R.length (content b)) $ 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)} + 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)} + 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 + 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 Expose -> redraw Selection e -> lift $ allocaXEvent $ \ev -> do setEventType ev selectionNotify @@ -338,8 +337,8 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do xUtf8String = 315 :: Atom sendCommand b c = do - attrs <- getTerminalAttributes (pty b) - writePty (pty b) (B.fromString [fromJust $ controlChar attrs c]) + attrs <- getTerminalAttributes (pty b) + writePty (pty b) (B.fromString [fromJust $ controlChar attrs c]) redraw = do drawWin display win bgcolour fgcolour linecolour selcolour font @@ -377,7 +376,7 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do expandTabs = go . T.splitOn "\t" where - go (a:b:xs) = a <> T.pack (replicate (8-T.length a `mod` 8) ' ') <> go (b : xs) + 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 @@ -387,7 +386,7 @@ main :: IO () main = do setLocaleEncoding utf8 env <- getEnvironment - let shell = case filter (\(var,_) -> var == "SHELL") env of [(_,x)] -> x; _ -> "sh" + 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 @@ -402,15 +401,14 @@ main = do 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)) + 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)) |