Skip to content

terminal: replace TMVar with TQueue for input event #1

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
shumvgolove wants to merge 1 commit into
base: fix-ioctl
Choose a base branch
from
Open

terminal: replace TMVar with TQueue for input event #1

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
11 changes: 6 additions & 5 deletions platform/posix/src/System/Terminal/Platform.hsc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ import Control.Concurrent
import qualified Control.Concurrent.Async as A
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM.TQueue
import qualified Control.Exception as E
import Control.Monad (forM_, void, when)
import Control.Monad.Catch hiding (handle)
Expand Down Expand Up @@ -61,7 +62,7 @@ withTerminal action = do
mainThread <- liftIO myThreadId
interrupt <- liftIO (newTVarIO False)
windowChanged <- liftIO (newTVarIO False)
events <- liftIO newEmptyTMVarIO
events <- liftIO newTQueueIO
cursorPosition <- liftIO newEmptyTMVarIO
withTermiosSettings $ \termios->
withInterruptHandler (handleInterrupt mainThread interrupt) $
Expand All @@ -73,7 +74,7 @@ withTerminal action = do
changed <- swapTVar windowChanged False
if changed
then pure (WindowEvent WindowSizeChanged)
else takeTMVar events
else readTQueue events
, localInterrupt = swapTVar interrupt False >>= check >> pure Interrupt
, localGetCursorPosition = do
-- Empty the result variable.
Expand Down Expand Up @@ -147,7 +148,7 @@ withInterruptHandler handler = bracket installHandler restoreHandler . const
pure ()

withInputProcessing :: (MonadIO m, MonadMask m) =>
Termios -> TMVar Position -> TMVar Event -> m a -> m a
Termios -> TMVar Position -> TQueue Event -> m a -> m a
withInputProcessing termios cursorPosition events =
bracket (liftIO $ A.async $ run decoder) (liftIO . A.cancel) . const
where
Expand Down Expand Up @@ -188,8 +189,8 @@ withInputProcessing termios cursorPosition events =
-- The second one is not strictly required but a fail safe in order
-- to never block in case the terminal sends a report without request.
putTMVar cursorPosition pos <|> void (swapTMVar cursorPosition pos)
putTMVar events ev
ev -> atomically (putTMVar events ev)
writeTQueue events ev
ev -> atomically (writeTQueue events ev)

-- The timeout duration has been choosen as a tradeoff between correctness
-- (actual transmission or scheduling delays shall not be misinterpreted) and
Expand Down
11 changes: 5 additions & 6 deletions platform/windows/src/System/Terminal/Platform.hsc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ module System.Terminal.Platform

import Control.Applicative ((<|>))
import Control.Concurrent (ThreadId, myThreadId, forkIO)
import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM.TQueue
import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, readTVarIO, swapTVar, writeTVar)
import qualified Control.Exception as E
import Control.Monad (forM_, when, unless)
Expand Down Expand Up @@ -53,7 +53,7 @@ withTerminal action = do
mainThread <- liftIO myThreadId
interrupt <- liftIO (newTVarIO False)
windowChanged <- liftIO (newTVarIO False)
events <- liftIO newEmptyTMVarIO
events <- liftIO newTQueueIO
withConsoleModes $
withInputProcessing mainThread interrupt windowChanged events $ action $ LocalTerminal
{ localType = "xterm" -- They claim it behaves like xterm although this is certainly a bit ambituous.
Expand All @@ -63,7 +63,7 @@ withTerminal action = do
changed <- swapTVar windowChanged False
if changed
then pure (WindowEvent WindowSizeChanged)
else takeTMVar events
else readTQueue events
}

decoder0 :: Decoder
Expand Down Expand Up @@ -143,7 +143,7 @@ putText text = do
written <- peek ptrWritten
when (written < len) (put (BS.drop (fromIntegral len * 2) bs) ptrWritten)

withInputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> TVar Bool -> TVar Bool -> TMVar Event -> m a -> m a
withInputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> TVar Bool -> TVar Bool -> TQueue Event -> m a -> m a
withInputProcessing mainThread interrupt windowChanged events ma = do
terminate <- liftIO (newTVarIO False)
terminated <- liftIO (newTVarIO False)
Expand All @@ -166,8 +166,7 @@ withInputProcessing mainThread interrupt windowChanged events ma = do
shallTerminate <- readTVarIO terminate
unless shallTerminate (waitForEvents decoder)
pushEvent :: Event -> IO ()
pushEvent ev = atomically do -- unblock when thread shall terminate
putTMVar events ev <|> (readTVar terminate >>= check)
pushEvent ev = atomically $ writeTQueue events ev
waitForEvents :: Decoder -> IO ()
waitForEvents decoder = tryGetConsoleInputEvent >>= \case
-- `tryGetConsoleInputEvent` is a blocking system call. It cannot be interrupted, but
Expand Down