104 lines
3.1 KiB
Haskell
104 lines
3.1 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module ChatTerminal
|
|
( ChatTerminal (..),
|
|
newChatTerminal,
|
|
chatTerminal,
|
|
ttyContact,
|
|
ttyFromContact,
|
|
)
|
|
where
|
|
|
|
import ChatTerminal.Basic
|
|
import ChatTerminal.Core
|
|
import ChatTerminal.Editor
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Concurrent.Async (race_)
|
|
import Control.Monad
|
|
import Numeric.Natural
|
|
import Styled
|
|
import System.Terminal
|
|
import Types
|
|
import UnliftIO.STM
|
|
|
|
newChatTerminal :: Natural -> TermMode -> IO ChatTerminal
|
|
newChatTerminal qSize termMode = do
|
|
inputQ <- newTBQueueIO qSize
|
|
outputQ <- newTBQueueIO qSize
|
|
activeContact <- newTVarIO Nothing
|
|
termSize <- withTerminal . runTerminalT $ getWindowSize
|
|
let lastRow = height termSize - 1
|
|
termState <- newTVarIO newTermState
|
|
termLock <- newTMVarIO ()
|
|
nextMessageRow <- newTVarIO lastRow
|
|
threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
|
|
return ChatTerminal {inputQ, outputQ, activeContact, termMode, termState, termSize, nextMessageRow, termLock}
|
|
|
|
newTermState :: TerminalState
|
|
newTermState =
|
|
TerminalState
|
|
{ inputString = "",
|
|
inputPosition = 0,
|
|
inputPrompt = "> ",
|
|
previousInput = ""
|
|
}
|
|
|
|
chatTerminal :: ChatTerminal -> IO ()
|
|
chatTerminal ct
|
|
| termSize ct == Size 0 0 || termMode ct == TermModeBasic =
|
|
run basicReceiveFromTTY basicSendToTTY
|
|
| otherwise = do
|
|
withTerminal . runTerminalT $ updateInput ct
|
|
run receiveFromTTY sendToTTY
|
|
where
|
|
run receive send = race_ (receive ct) (send ct)
|
|
|
|
basicReceiveFromTTY :: ChatTerminal -> IO ()
|
|
basicReceiveFromTTY ct =
|
|
forever $ getLn >>= atomically . writeTBQueue (inputQ ct)
|
|
|
|
basicSendToTTY :: ChatTerminal -> IO ()
|
|
basicSendToTTY ct = forever $ readOutputQ ct >>= mapM_ putStyledLn
|
|
|
|
withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
|
|
withTermLock ChatTerminal {termLock} action = do
|
|
_ <- atomically $ takeTMVar termLock
|
|
action
|
|
atomically $ putTMVar termLock ()
|
|
|
|
receiveFromTTY :: ChatTerminal -> IO ()
|
|
receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
|
|
withTerminal . runTerminalT . forever $
|
|
getKey >>= processKey >> withTermLock ct (updateInput ct)
|
|
where
|
|
processKey :: MonadTerminal m => (Key, Modifiers) -> m ()
|
|
processKey = \case
|
|
(EnterKey, _) -> submitInput
|
|
key -> atomically $ do
|
|
ac <- readTVar activeContact
|
|
modifyTVar termState $ updateTermState ac (width termSize) key
|
|
|
|
submitInput :: MonadTerminal m => m ()
|
|
submitInput = do
|
|
msg <- atomically $ do
|
|
ts <- readTVar termState
|
|
let s = inputString ts
|
|
writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s}
|
|
writeTBQueue inputQ s
|
|
return s
|
|
withTermLock ct $ printMessage ct [styleMessage msg]
|
|
|
|
sendToTTY :: ChatTerminal -> IO ()
|
|
sendToTTY ct = forever $ do
|
|
-- `readOutputQ` should be outside of `withTerminal` (see #94)
|
|
msg <- readOutputQ ct
|
|
withTerminal . runTerminalT . withTermLock ct $ do
|
|
printMessage ct msg
|
|
updateInput ct
|
|
|
|
readOutputQ :: ChatTerminal -> IO [StyledString]
|
|
readOutputQ = atomically . readTBQueue . outputQ
|