diff options
| -rw-r--r-- | main/Main.hs | 2 | ||||
| -rw-r--r-- | main/Terminal.hs | 33 |
2 files changed, 27 insertions, 8 deletions
diff --git a/main/Main.hs b/main/Main.hs index 4a85f4e..8d7cc08 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -418,7 +418,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do _ <- liftIO $ do tzone <- getCurrentTimeZone let self = finalOwner $ headLocalIdentity erebosHead - watchDirectMessageThreads erebosHead $ \prev cur -> do + watchDirectMessageThreads erebosHead $ \prev cur -> holdFlush term $ do let ( remove, messages ) = dmThreadToListChange prev cur when (remove > 0) $ do modifyMVar_ currentLinesVar $ \clines -> if diff --git a/main/Terminal.hs b/main/Terminal.hs index 53814f9..5b814f8 100644 --- a/main/Terminal.hs +++ b/main/Terminal.hs @@ -5,6 +5,7 @@ module Terminal ( Terminal, hasTerminalUI, withTerminal, + holdFlush, setPrompt, setPromptStatus, showPrompt, hidePrompt, @@ -59,6 +60,7 @@ data Terminal = Terminal , termHistoryPos :: TVar Int , termHistoryStash :: TVar ( String, String ) , termBottomIndex :: TVar Int + , termHoldFlush :: TVar Int } data TerminalLine = TerminalLine @@ -108,6 +110,7 @@ initTerminal termCompletionFunc = do termHistoryPos <- newTVarIO 0 termHistoryStash <- newTVarIO ( "", "" ) termBottomIndex <- newTVarIO 0 + termHoldFlush <- newTVarIO 0 return Terminal {..} bracketSet :: IO a -> (a -> IO b) -> a -> IO c -> IO c @@ -123,6 +126,22 @@ withTerminal compl act = do act term +termFlush :: Terminal -> IO () +termFlush Terminal {..} = do + join $ atomically $ do + readTVar termHoldFlush >>= \case + 0 -> return $ hFlush stdout + _ -> return $ return () + +holdFlush :: Terminal -> IO a -> IO a +holdFlush term@Terminal {..} act = do + atomically $ writeTVar termHoldFlush . (+ 1) =<< readTVar termHoldFlush + x <- act + atomically $ writeTVar termHoldFlush . subtract 1 =<< readTVar termHoldFlush + termFlush term + return x + + putAnsi :: AnsiText -> IO () putAnsi = T.putStr . fromAnsiText @@ -201,7 +220,7 @@ getInputLine term@Terminal {..} handleResult = do writeTVar termInput ( pre', post ) getCurrentPromptLine term putAnsi $ "\r" <> prompt - hFlush stdout + termFlush term termCompletionFunc ( T.pack pre, T.pack post ) >>= \case @@ -310,7 +329,7 @@ getInputLine term@Terminal {..} handleResult = do str <- atomically $ f =<< readTVar termInput when (termAnsi && not (T.null $ fromAnsiText str)) $ do putAnsi str - hFlush stdout + termFlush term go @@ -332,7 +351,7 @@ redrawPrompt term = do promptLine <- getCurrentPromptLine term return $ do putAnsi $ "\r\ESC[K" <> promptLine - hFlush stdout + termFlush term setPrompt :: Terminal -> FormattedText -> IO () setPrompt Terminal { termAnsi = False } _ = do @@ -403,7 +422,7 @@ printLine tlTerminal@Terminal {..} str = do writeTVar termBottomIndex $ bindex + tlLineCount return bindex - hFlush stdout + termFlush tlTerminal return TerminalLine {..} updateLine :: TerminalLine -> FormattedText -> IO () @@ -443,19 +462,19 @@ printBottomLines term@Terminal {..} str = do withMVar termLock $ \_ -> do atomically $ writeTVar termBottomLines blines drawBottomLines term - hFlush stdout + termFlush term clearBottomLines :: Terminal -> IO () clearBottomLines Terminal { termAnsi = False } = do return () -clearBottomLines Terminal {..} = do +clearBottomLines term@Terminal {..} = do withMVar termLock $ \_ -> do atomically (readTVar termBottomLines) >>= \case [] -> return () _:_ -> do atomically $ writeTVar termBottomLines [] putStr $ "\ESC[s\n\ESC[J\ESC[u" - hFlush stdout + termFlush term drawBottomLines :: Terminal -> IO () drawBottomLines Terminal {..} = do |