simplex-chat/ChatTerminal/Editor.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

module ChatTerminal.Editor where

import ChatTerminal.Basic
import ChatTerminal.Core
import Styled
import System.Terminal
import UnliftIO.STM

-- debug :: MonadTerminal m => String -> m ()
-- debug s = do
--   saveCursor
--   setCursorPosition $ Position 0 0
--   putString s
--   restoreCursor

updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
updateInput ct@ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do
  hideCursor
  ts <- readTVarIO termState
  nmr <- readTVarIO nextMessageRow
  let ih = inputHeight ts ct
      iStart = height - ih
      prompt = inputPrompt ts
      Position {row, col} = positionRowColumn width $ length prompt + inputPosition ts
  if nmr >= iStart
    then atomically $ writeTVar nextMessageRow iStart
    else clearLines nmr iStart
  setCursorPosition $ Position {row = max nmr iStart, col = 0}
  putString $ prompt <> inputString ts <> " "
  eraseInLine EraseForward
  setCursorPosition $ Position {row = iStart + row, col}
  showCursor
  flush
  where
    clearLines :: Int -> Int -> m ()
    clearLines from till
      | from >= till = return ()
      | otherwise = do
        setCursorPosition $ Position {row = from, col = 0}
        eraseInLine EraseForward
        clearLines (from + 1) till

printMessage :: MonadTerminal m => ChatTerminal -> StyledString -> m ()
printMessage ChatTerminal {termSize = Size {height, width}, nextMessageRow} msg = do
  nmr <- readTVarIO nextMessageRow
  setCursorPosition $ Position {row = nmr, col = 0}
  let lc = sLength msg `div` width + 1
  putStyled msg
  eraseInLine EraseForward
  putLn
  flush
  atomically . writeTVar nextMessageRow $ min (height - 1) (nmr + lc)