diff options
Diffstat (limited to 'jterm.hs')
| -rw-r--r-- | jterm.hs | 159 |
1 files changed, 79 insertions, 80 deletions
@@ -7,8 +7,6 @@ import Control.Concurrent 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 @@ -136,35 +134,34 @@ 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 - (_, _, _, 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 :: Int) (0 :: Int) 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 :: 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 +drawWin :: MVar Buffer -> Display -> Drawable -> XftColor -> XftColor -> XftColor -> XftColor -> XftFont -> IO () +drawWin bufVar display win bgcolour fgcolour linecolour selcolour font = do + buf <- readMVar bufVar + (_, _, _, 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 :: Int) (0 :: Int) 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 :: 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 () @@ -307,53 +304,54 @@ waitEvent display event = 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 - (_, _, _, _, m, _, _) <- lift $ getGeometry display win +handleEvent :: MVar Buffer -> Display -> Drawable -> XftColor -> XftColor -> XftColor -> XftColor -> XftFont -> HandledEvent -> IO () +handleEvent buffer display win bgcolour fgcolour linecolour selcolour font event = do + b <- readMVar buffer + (_, _, _, _, m, _, _) <- getGeometry display win let (start, end) = cursor b selstr = R.splitAt end (content b) & fst & R.splitAt start & snd (height, _) = fontSize display font pageheight = fromIntegral m `div` fromIntegral height case event of Key (_, _, time, x, y, _, _, mod, keycode, _) -> do - keysym <- lift $ keycodeToKeysym display keycode 0 + keysym <- 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 - if (time - lastLeftClick b) < doubleClickDelay - then put $ b {cursor = expandAround (content b) p, selection = Nothing, lastLeftClick = time} - else put $ b {cursor = (p, p), selection = Just (x, y), lastLeftClick = time} + updateBuffer' $ \b -> do + p <- getPos x y b + if (time - lastLeftClick b) < doubleClickDelay + then pure $ b {cursor = expandAround (content b) p, selection = Nothing, lastLeftClick = time} + else pure $ b {cursor = (p, p), selection = Just (x, y), lastLeftClick = time} (_, 1) -> -- left click up - put $ b {selection = Nothing} + updateBuffer $ \b -> b {selection = Nothing} (0, 3) -> -- right click down - case search selstr (content b) (1 + end) of - Just p -> do - put $ b {cursor = (p, p + end - start), pos = max (pos b) $ R.lengthInLines (R.splitAt p (content b) & fst) + 1 -. pageheight} - Nothing -> pure () + updateBuffer $ \b -> + case search selstr (content b) (1 + end) of + Just p -> b {cursor = (p, p + end - start), pos = max (pos b) $ R.lengthInLines (R.splitAt p (content b) & fst) + 1 -. pageheight} + Nothing -> b (0, 2) -> -- middle click down case bsearch selstr (content b) (start -. 1) of Just p -> do - put $ b {cursor = (p + start - end, p), pos = min (pos b) $ R.lengthInLines (R.splitAt p (content b) & fst) -. 1} + updateBuffer $ \b -> b {cursor = (p + start - end, p), pos = min (pos b) $ R.lengthInLines (R.splitAt p (content b) & fst) -. 1} Nothing -> pure () (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)} + p <- getPos x0 y0 b + q <- getPos x y b + updateBuffer $ \b -> b {cursor = (min p q, max p q)} _ -> do case (mod, keysym) of (4, 117) -> do -- ctrl-u (delete content before cursor) - put $ b {pos = 0} + updateBuffer $ \b -> b {pos = 0} delins 0 start "" (4, 105) -> -- ctrl-i (delete content after cursor) @@ -361,51 +359,49 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do (4, 108) -> -- ctrl-l (restrip buffer of ansi codes) delins' True 0 (R.length (content b)) (content b & R.toText & stripAnsiEscapeCodes & R.fromText) - (4, 99) -> lift $ do + (4, 99) -> do -- ctrl-c (copy) storeBuffer display (R.toText selstr & T.unpack) 0 xSetSelectionOwner display pRIMARY win time xSetSelectionOwner display sECONDARY win time (4, 120) -> do -- ctrl-x (cut) - lift $ storeBuffer display (R.toText selstr & T.unpack) 0 + storeBuffer display (R.toText selstr & T.unpack) 0 delins start end "" - (4, 118) -> lift $ do + (4, 118) -> do -- ctrl-v (paste) prop <- internAtom display "JTERM_CLIPBOARD" True xConvertSelection display pRIMARY xUtf8String prop win time - (4, 113) -> lift $ do + (4, 113) -> do -- ctrl-q (write log) home <- getEnv "HOME" T.writeFile (home <> "/jterm.log") (R.toText (content b)) (4, 100) -> do -- ctrl-d (send without sending to pty) - put $ b {content = content b <> selstr <> " "} + updateBuffer $ \b -> b {content = content b <> selstr <> " "} (4, 115) -> do -- ctrl-s (send) - put $ b {content = content b <> selstr <> "\n"} + updateBuffer $ \b -> b {content = content b <> selstr <> "\n"} sendline (_, 65361) -> do -- left let s = start - min start 1 - put $ b {cursor = (s, s)} + updateBuffer $ \b -> 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 + updateBuffer $ \b -> b {cursor = (e, e)} + (_, 65535) -> sendCommand b Interrupt + (_, 65360) -> updateBuffer $ \b -> b {pos = 0} -- home (_, 65367) -> do -- end let e = R.length (content b) - put $ b {cursor = (e, e)} + updateBuffer $ \b -> b {cursor = (e, e)} scrolldown (maxBound - pos b) (_, 65362) -> scrollup 1 (_, 65364) -> scrolldown 1 - (_, 65365) -> do - scrollup ((681 * pageheight) `div` 1000) - (_, 65366) -> do - scrolldown ((681 * pageheight) `div` 1000) + (_, 65365) -> scrollup ((681 * pageheight) `div` 1000) + (_, 65366) -> scrolldown ((681 * pageheight) `div` 1000) (_, 65288) -> do -- backspace delins (start - 1) end "" @@ -422,14 +418,14 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do delins' True (ptycursor b) (ptycursor b) $ R.fromText expandedTabs when (pl + pageheight > cl) redraw Notify -> do - prop <- lift $ internAtom display "JTERM_CLIPBOARD" False - lift (getWindowProperty8 display prop win) >>= \case + prop <- internAtom display "JTERM_CLIPBOARD" False + 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 + Selection e -> allocaXEvent $ \ev -> do setEventType ev selectionNotify if ev_target e == xUtf8String then do @@ -443,26 +439,29 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do where xUtf8String = 315 :: Atom + updateBuffer' f = modifyMVar_ buffer $ \x -> f x + updateBuffer f = modifyMVar_ buffer $ \x -> pure $ f x + sendline = do - b <- get + b <- takeMVar buffer let cmd = between (ptycursor b) (R.length $ content b) (content b) - put $ b {ptycursor = R.length (content b)} - lift $ send b cmd + putMVar buffer $ b {ptycursor = R.length (content b)} + send b cmd 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 + drawWin buffer display win bgcolour fgcolour linecolour selcolour font + 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 + b <- takeMVar buffer let l = R.length ins p = ptycursor b p' @@ -475,7 +474,7 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do | ce <= s = (cs, ce) | ce <= e && cs >= s = (s + l, s + l) | otherwise = (min cs ce, ce + s - e) - put $ b {content = doedit s e (content b) ins, cursor = c', ptycursor = if movepty then s + l else p'} + putMVar buffer $ 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 @@ -501,8 +500,8 @@ handleEvent display win bgcolour fgcolour linecolour selcolour font event = do 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)} + scrollup k = updateBuffer $ \b -> b {pos = pos b - min (pos b) k} + scrolldown k = updateBuffer $ \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) @@ -545,6 +544,6 @@ main = do withXftColorValue display visual colourmap (XRenderColor 0xf7f7 0xeaea 0xffff 0xffff) $ \selcolour -> 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) 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)) + allocaXEvent $ \e -> do + buffer <- newMVar (Buffer 0 "" (0, 0) 0 Nothing pty 0) + S.parList id [S.repeatM (waitEvent display e), S.repeatM (watch pty)] & S.fold (F.drainMapM (handleEvent buffer display win bgcolour fgcolour linecolour selcolour font)) |