switch to MVars

1 files changed, 79 insertions, 80 deletions

diff --git a/jterm.hs b/jterm.hs
index 1fe3c7e..ac012af 100644
--- a/jterm.hs
+++ b/jterm.hs
@@ -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))