From 3630677c07768781376242f5c0919a6c9cb5d7fe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 1 Feb 2026 20:26:42 +0100 Subject: Use FormattedText for terminal prompt --- main/Main.hs | 3 ++- main/State.hs | 13 +++++++----- main/Terminal.hs | 48 ++++++++++++++++++++++--------------------- src/Erebos/TextFormat.hs | 13 ++++++++++++ src/Erebos/TextFormat/Ansi.hs | 3 +++ 5 files changed, 51 insertions(+), 29 deletions(-) diff --git a/main/Main.hs b/main/Main.hs index 2d11dba..5fca2d9 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -54,6 +54,7 @@ import Erebos.Storable import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync +import Erebos.TextFormat import Erebos.TextFormat.Ansi import State @@ -358,7 +359,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do SelectedConversation conv -> return $ T.unpack $ conversationName conv return $ pname ++ "> " Right prompt -> return prompt - lift $ setPrompt term prompt + lift $ setPrompt term $ plainText $ T.pack prompt join $ lift $ getInputLine term $ \case Just input@('/' : _) -> KeepPrompt $ return input Just input -> ErasePrompt $ case reverse input of diff --git a/main/State.hs b/main/State.hs index 5d66ba9..0e20320 100644 --- a/main/State.hs +++ b/main/State.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module State ( loadLocalStateHead, createLocalStateHead, @@ -20,6 +22,7 @@ import Erebos.PubKey import Erebos.State import Erebos.Storable import Erebos.Storage +import Erebos.TextFormat import Terminal @@ -96,12 +99,12 @@ interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError interactiveIdentityUpdate term fidentity = do identity <- mergeIdentity fidentity name <- liftIO $ do - setPrompt term $ T.unpack $ T.concat $ concat - [ [ T.pack "Name" ] + setPrompt term $ mconcat $ concat + [ [ "Name" ] , case idName identity of - Just name -> [T.pack " [", name, T.pack "]"] - Nothing -> [] - , [ T.pack ": " ] + Just name -> [ " [", plainText name, "]" ] + Nothing -> [] + , [ ": " ] ] getInputLine term $ KeepPrompt . maybe T.empty T.pack diff --git a/main/Terminal.hs b/main/Terminal.hs index b8b953f..97c5683 100644 --- a/main/Terminal.hs +++ b/main/Terminal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Terminal ( Terminal, @@ -28,19 +29,24 @@ import Control.Monad import Data.Char import Data.List +import Data.String import Data.Text (Text) import Data.Text qualified as T +import Data.Text.IO qualified as T import System.Console.ANSI import System.IO import System.IO.Error +import Erebos.TextFormat +import Erebos.TextFormat.Ansi + data Terminal = Terminal { termLock :: MVar () , termAnsi :: Bool , termCompletionFunc :: CompletionFunc IO - , termPrompt :: TVar String + , termPrompt :: TVar FormattedText , termShowPrompt :: TVar Bool , termInput :: TVar ( String, String ) , termBottomLines :: TVar [ String ] @@ -114,6 +120,9 @@ termPutStr Terminal {..} str = do putStr str hFlush stdout +putAnsi :: AnsiText -> IO () +putAnsi = T.putStr . fromAnsiText + getInput :: IO Input getInput = do @@ -154,7 +163,7 @@ getInputLine term@Terminal {..} handleResult = do prompt <- atomically $ do writeTVar termShowPrompt True readTVar termPrompt - putStr $ prompt <> "\ESC[K" + putAnsi $ renderAnsiText prompt <> "\ESC[K" drawBottomLines term hFlush stdout @@ -195,7 +204,7 @@ getInputLine term@Terminal {..} handleResult = do prompt <- atomically $ do writeTVar termInput ( pre', post ) getCurrentPromptLine term - putStr $ "\r" <> prompt + putAnsi $ "\r" <> prompt hFlush stdout termCompletionFunc ( T.pack pre, T.pack post ) >>= \case @@ -222,7 +231,7 @@ getInputLine term@Terminal {..} handleResult = do InputChar c | isPrint c -> withInput $ \case ( _, post ) -> do writeTVar termInput . first (++ [ c ]) =<< readTVar termInput - return $ c : (if null post then "" else "\ESC[s" <> post <> "\ESC[u") + return $ AnsiText $ T.pack $ c : (if null post then "" else "\ESC[s" <> post <> "\ESC[u") InputChar _ -> go @@ -272,7 +281,7 @@ getInputLine term@Terminal {..} handleResult = do InputBackspace -> withInput $ \case ( pre@(_ : _), post ) -> do writeTVar termInput ( init pre, post ) - return $ "\b\ESC[K" <> (if null post then "" else "\ESC[s" <> post <> "\ESC[u") + return $ AnsiText $ "\b\ESC[K" <> (if null post then "" else "\ESC[s" <> T.pack post <> "\ESC[u") _ -> return "" InputClear -> withInput $ \_ -> do @@ -286,11 +295,11 @@ getInputLine term@Terminal {..} handleResult = do InputMoveStart -> withInput $ \( pre, post ) -> do writeTVar termInput ( "", pre <> post ) - return $ "\ESC[" <> show (length pre) <> "D" + return $ AnsiText $ T.pack $ "\ESC[" <> show (length pre) <> "D" InputMoveEnd -> withInput $ \( pre, post ) -> do writeTVar termInput ( pre <> post, "" ) - return $ "\ESC[" <> show (length post) <> "C" + return $ AnsiText $ T.pack $ "\ESC[" <> show (length post) <> "C" InputEnd -> do atomically (readTVar termInput) >>= \case @@ -299,22 +308,23 @@ getInputLine term@Terminal {..} handleResult = do InputEscape _ -> go + withInput :: (( String, String ) -> STM AnsiText) -> IO (Maybe String) withInput f = do withMVar termLock $ const $ do str <- atomically $ f =<< readTVar termInput - when (termAnsi && not (null str)) $ do - putStr str + when (termAnsi && not (T.null $ fromAnsiText str)) $ do + putAnsi str hFlush stdout go -getCurrentPromptLine :: Terminal -> STM String +getCurrentPromptLine :: Terminal -> STM AnsiText getCurrentPromptLine Terminal {..} = do prompt <- readTVar termPrompt ( pre, post ) <- readTVar termInput - return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u" + return $ mconcat [ renderAnsiText prompt, AnsiText (T.pack pre), "\ESC[s", AnsiText (T.pack post), "\ESC[u" ] -setPrompt :: Terminal -> String -> IO () +setPrompt :: Terminal -> FormattedText -> IO () setPrompt Terminal { termAnsi = False } _ = do return () setPrompt term@Terminal {..} prompt = do @@ -325,7 +335,7 @@ setPrompt term@Terminal {..} prompt = do True -> do promptLine <- getCurrentPromptLine term return $ do - putStr $ "\r\ESC[K" <> promptLine + putAnsi $ "\r\ESC[K" <> promptLine hFlush stdout False -> return $ return () @@ -340,7 +350,7 @@ printLine tlTerminal@Terminal {..} str = do readTVar termShowPrompt >>= \case True -> getCurrentPromptLine tlTerminal False -> return "" - putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine + putAnsi $ "\r\ESC[K" <> fromString (unlines strLines) <> "\ESC[K" <> promptLine drawBottomLines tlTerminal else do putStr $ unlines strLines @@ -382,7 +392,7 @@ drawBottomLines Terminal {..} = do True -> do prompt <- readTVar termPrompt ( pre, _ ) <- readTVar termInput - return (displayWidth (prompt <> pre) + 1) + return (formattedTextLength prompt + length pre + 1) False -> do return 0 putStr $ concat @@ -393,14 +403,6 @@ drawBottomLines Terminal {..} = do [] -> return () -displayWidth :: String -> Int -displayWidth = \case - ('\ESC' : '[' : rest) -> displayWidth $ drop 1 $ dropWhile (not . isAlpha) rest - ('\ESC' : _ : rest) -> displayWidth rest - (_ : rest) -> 1 + displayWidth rest - [] -> 0 - - type CompletionFunc m = ( Text, Text ) -> m ( Text, [ Completion ] ) data Completion = Completion diff --git a/src/Erebos/TextFormat.hs b/src/Erebos/TextFormat.hs index 0bfad75..20973d9 100644 --- a/src/Erebos/TextFormat.hs +++ b/src/Erebos/TextFormat.hs @@ -1,16 +1,29 @@ module Erebos.TextFormat ( FormattedText, + plainText, renderPlainText, + formattedTextLength, ) where import Data.Text (Text) +import Data.Text qualified as T import Erebos.TextFormat.Types +plainText :: Text -> FormattedText +plainText = PlainText + + renderPlainText :: FormattedText -> Text renderPlainText = \case PlainText text -> text ConcatenatedText ftexts -> mconcat $ map renderPlainText ftexts FormattedText _ ftext -> renderPlainText ftext + +formattedTextLength :: FormattedText -> Int +formattedTextLength = \case + PlainText text -> T.length text + ConcatenatedText ftexts -> sum $ map formattedTextLength ftexts + FormattedText _ ftext -> formattedTextLength ftext diff --git a/src/Erebos/TextFormat/Ansi.hs b/src/Erebos/TextFormat/Ansi.hs index 504e098..c0ff978 100644 --- a/src/Erebos/TextFormat/Ansi.hs +++ b/src/Erebos/TextFormat/Ansi.hs @@ -9,6 +9,7 @@ module Erebos.TextFormat.Ansi ( import Control.Applicative +import Data.String import Data.Text (Text) import Data.Text qualified as T @@ -16,6 +17,8 @@ import Erebos.TextFormat.Types newtype AnsiText = AnsiText { fromAnsiText :: Text } + deriving (Eq, Ord, Semigroup, Monoid, IsString) + renderAnsiText :: FormattedText -> AnsiText renderAnsiText = AnsiText . go ( Nothing, Nothing ) -- cgit v1.2.3