From 722e30758b7a222a0e074bd17d8116001560c156 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 7 Feb 2026 17:10:21 +0100 Subject: Terminal: use FormattedText in printLine --- main/Main.hs | 75 +++++++++++++++++++++--------------------- main/Terminal.hs | 13 ++++---- src/Erebos/TextFormat.hs | 31 +++++++++++++++++ src/Erebos/TextFormat/Ansi.hs | 37 ++++++++++++++++----- src/Erebos/TextFormat/Types.hs | 1 + 5 files changed, 105 insertions(+), 52 deletions(-) diff --git a/main/Main.hs b/main/Main.hs index 798e8f3..3928621 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -55,7 +55,6 @@ import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync import Erebos.TextFormat -import Erebos.TextFormat.Ansi import State import Terminal @@ -329,7 +328,7 @@ main = do | otherwise -> interactiveLoop st opts (cmdname : _) -> do - hPutStrLn stderr $ "Unknown command `" <> cmdname <> "'" + hPutStrLn stderr $ "Unknown command ‘" <> cmdname <> "’" exitFailure @@ -340,7 +339,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do case optCreateIdentity opts of Nothing -> loadLocalStateHead term Just ( devName, names ) -> createLocalStateHead (names ++ [ devName ]) - void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead + void $ printLine term $ plainText $ displayIdentity $ headLocalIdentity erebosHead let tui = hasTerminalUI term let extPrintLn = void . printLine term @@ -406,7 +405,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do SelectedConversation conv -> return $ conversationPeer conv _ -> return Nothing when (not tui || maybe False (msgPeer cur `sameIdentity`) mbpid) $ do - extPrintLn $ formatDirectMessage tzone msg + extPrintLn $ plainText $ T.pack $ formatDirectMessage tzone msg case optDmBotEcho opts of Just prefix @@ -436,11 +435,11 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do return Nothing server <- liftIO $ do - startServer (optServer opts) erebosHead extPrintLn $ + startServer (optServer opts) erebosHead (extPrintLn . plainText . T.pack) $ map soptService $ filter soptEnabled $ optServices opts case optWebSocketServer opts of - Just port -> startWebsocketServer server "::" port extPrintLn + Just port -> startWebsocketServer server "::" port (extPrintLn . plainText . T.pack) Nothing -> return () void $ liftIO $ forkIO $ void $ forever $ do @@ -466,7 +465,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do -> do let ( clist', idx ) = ctxUpdate (1 :: Int) clist when (Just shown /= op) $ do - extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown + extPrintLn $ plainText $ T.pack $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown return ( Just WatchPeers, clist' ) cur -> return cur _ -> return () @@ -500,7 +499,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do | csQuit cstate' -> mzero | otherwise -> return cstate' Left err -> do - lift $ extPrintLn $ "Error: " ++ showErebosError err + lift $ extPrintLn $ withStyle (setForegroundColor BrightRed noStyle) $ plainText $ T.pack $ "Error: " ++ showErebosError err return cstate let loop (Just cstate) = runMaybeT (process cstate) >>= loop @@ -518,7 +517,7 @@ data CommandInput = CommandInput { ciServer :: Server , ciTerminal :: Terminal , ciLine :: String - , ciPrint :: String -> IO () + , ciPrint :: FormattedText -> IO () , ciOptions :: Options , ciPeers :: CommandM [(Peer, String)] , ciContextOptions :: CommandM [ CommandContext ] @@ -670,13 +669,13 @@ commandCompletion = completeWordWithPrev Nothing [ ' ', '\t', '\n', '\r' ] $ cur sortedCommandNames = sort $ map fst commands -cmdPutStrLn :: String -> Command +cmdPutStrLn :: FormattedText -> Command cmdPutStrLn str = do term <- asks ciTerminal void $ liftIO $ printLine term str cmdUnknown :: String -> Command -cmdUnknown cmd = cmdPutStrLn $ "Unknown command: " ++ cmd +cmdUnknown cmd = cmdPutStrLn $ withStyle (setForegroundColor BrightRed noStyle) $ plainText $ "Unknown command: ‘" <> T.pack cmd <> "’" cmdPeers :: Command cmdPeers = do @@ -684,7 +683,7 @@ cmdPeers = do set <- asks ciSetContextOptions set WatchPeers $ map (SelectedPeer . fst) peers forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do - cmdPutStrLn $ "[" ++ show i ++ "] " ++ name + cmdPutStrLn $ plainText $ T.pack $ "[" ++ show i ++ "] " ++ name cmdPeerAdd :: Command cmdPeerAdd = void $ do @@ -746,7 +745,7 @@ cmdMembers :: Command cmdMembers = do Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom forM_ (chatroomMembers room) $ \x -> do - cmdPutStrLn $ maybe "" T.unpack $ idName x + cmdPutStrLn $ plainText $ fromMaybe "" $ idName x getContextByIndex :: (Maybe ContextWatchOptions -> Maybe ContextWatchOptions) -> Int -> CommandM CommandContext getContextByIndex f n = do @@ -771,7 +770,7 @@ cmdSelectContext = do flip catchError (\_ -> return ()) $ do conv <- getConversationFromContext ctx tzone <- liftIO $ getCurrentTimeZone - mapM_ (cmdPutStrLn . T.unpack . fromAnsiText . renderAnsiText . formatMessageFT tzone) $ takeWhile messageUnread $ conversationHistory conv + mapM_ (cmdPutStrLn . formatMessageFT tzone) $ takeWhile messageUnread $ conversationHistory conv cmdSend :: Command cmdSend = void $ do @@ -790,9 +789,9 @@ cmdHistory = void $ do case conversationHistory conv of thread@(_:_) -> do tzone <- liftIO $ getCurrentTimeZone - mapM_ (cmdPutStrLn . T.unpack . fromAnsiText . renderAnsiText . formatMessageFT tzone) $ reverse $ take 50 thread + mapM_ (cmdPutStrLn . formatMessageFT tzone) $ reverse $ take 50 thread [] -> do - cmdPutStrLn $ "" + cmdPutStrLn $ withStyle (setForegroundColor BrightBlack noStyle) $ plainText "(empty history)" showIdentityDetails :: Foldable f => Identity f -> Text showIdentityDetails identity = T.unlines $ go $ reverse $ unfoldOwners identity @@ -810,7 +809,7 @@ showIdentityDetails identity = T.unlines $ go $ reverse $ unfoldOwners identity cmdIdentity :: Command cmdIdentity = do - cmdPutStrLn . T.unpack . showIdentityDetails . localIdentity . fromStored =<< getLocalHead + cmdPutStrLn . plainText . showIdentityDetails . localIdentity . fromStored =<< getLocalHead cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do @@ -827,7 +826,7 @@ cmdAttachReject :: Command cmdAttachReject = attachReject =<< getSelectedPeer watchChatroomsForCli - :: Bool -> (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) + :: Bool -> (FormattedText -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) -> MVar CommandContext -> MVar ( Maybe ContextWatchOptions, [ CommandContext ] ) -> Maybe Int -> IO WatchedHead watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe = do @@ -838,14 +837,14 @@ watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoS | currentRoots <- filterAncestors (concatMap storedRoots $ roomStateData rstate) , any ((`intersectsSorted` currentRoots) . storedRoots) $ roomStateData rstate' -> do - eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name + eprint $ plainText $ T.pack $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name return (SelectedChatroom rstate : rest) selected : rest -> do (selected : ) <$> ctxUpdate updateType (idx + 1) rstate rest [] -> do - eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name + eprint $ plainText $ T.pack $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name return [ SelectedChatroom rstate ] where name = maybe "" T.unpack $ roomName =<< roomStateRoom rstate @@ -865,7 +864,7 @@ watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoS forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case Right () -> return () - Left err -> eprint (showErebosError err) + Left err -> eprint $ plainText $ T.pack $ showErebosError err Just diff -> do modifyMVar_ chatroomSetVar $ return . const set @@ -901,11 +900,11 @@ watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoS when (not tui || isSelected) $ do tzone <- getCurrentTimeZone forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do - eprint $ concat $ - [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg - , maybe "" T.unpack $ idName $ cmsgFrom msg + eprint $ plainText $ T.concat + [ T.pack $ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg + , fromMaybe "" $ idName $ cmsgFrom msg , if cmsgLeave msg then " left" else "" - , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg + , maybe (if cmsgLeave msg then "" else " joined") ((": " <>)) $ cmsgText msg ] modifyMVar_ subscribedNumVar $ return . (if roomStateSubscribe rstate then (+ 1) else id) @@ -934,7 +933,7 @@ cmdChatrooms = do set <- asks ciSetContextOptions set WatchChatrooms $ map SelectedChatroom chatroomList forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do - cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "" T.unpack (roomName =<< roomStateRoom rstate) + cmdPutStrLn $ plainText $ "[" <> T.pack (show i) <> "] " <> fromMaybe "" (roomName =<< roomStateRoom rstate) cmdChatroomCreatePublic :: Command cmdChatroomCreatePublic = do @@ -962,7 +961,7 @@ cmdContacts = do set <- asks ciSetContextOptions set WatchContacts $ map SelectedContact contacts forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do - cmdPutStrLn $ T.unpack $ T.concat + cmdPutStrLn $ plainText $ T.concat [ "[", T.pack (show i), "] ", contactName c , case contactIdentity c of Just idt | cname <- displayIdentity idt @@ -994,7 +993,7 @@ cmdInviteContact = do Just (self :: ComposedIdentity) -> do invite <- createSingleContactInvite name dgst : _ <- return $ refDigest . storedRef <$> idDataF self - cmdPutStrLn $ "https://app.erebosprotocol.net/#inv" <> (maybe "" (("=" <>) . showInviteToken) (inviteToken invite)) <> "&from=blake2%23" <> drop 7 (show dgst) + cmdPutStrLn $ plainText $ "https://app.erebosprotocol.net/#inv" <> (maybe "" (("=" <>) . textInviteToken) (inviteToken invite)) <> "&from=blake2%23" <> T.pack (drop 7 (show dgst)) Nothing -> do throwOtherError "no shared identity" @@ -1026,7 +1025,7 @@ cmdConversations = do set <- asks ciSetContextOptions set WatchConversations $ map SelectedConversation conversations forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do - cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) + cmdPutStrLn $ plainText $ "[" <> T.pack (show i) <> "] " <> conversationName conv cmdNew :: Command cmdNew = do @@ -1035,7 +1034,7 @@ cmdNew = do set WatchConversations $ map (SelectedConversation . fst) conversations tzone <- liftIO $ getCurrentTimeZone forM_ (zip [1..] conversations) $ \(i :: Int, ( conv, msg )) -> do - cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) ++ " " ++ T.unpack (fromAnsiText $ renderAnsiText $ formatMessageFT tzone msg) + cmdPutStrLn $ plainText ("[" <> T.pack (show i) <> "] " <> conversationName conv <> " ") <> formatMessageFT tzone msg where checkNew conv | (msg : _) <- conversationHistory conv @@ -1049,23 +1048,23 @@ cmdDetails = do getSelectedOrManualContext >>= \case SelectedPeer peer -> do paddr <- getPeerAddress peer - cmdPutStrLn $ unlines + cmdPutStrLn $ plainText $ T.unlines [ "Network peer:" - , " " <> show paddr + , " " <> T.pack (show paddr) ] getPeerIdentity peer >>= \case PeerIdentityUnknown _ -> do cmdPutStrLn $ "unknown identity" PeerIdentityRef wref _ -> do cmdPutStrLn $ "Identity ref:" - cmdPutStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref) + cmdPutStrLn $ plainText $ " " <> T.decodeUtf8 (showRefDigest $ wrDigest wref) PeerIdentityFull pid -> printContactOrIdentityDetails pid SelectedContact contact -> do printContactDetails contact SelectedChatroom rstate -> do - cmdPutStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "") $ roomName =<< roomStateRoom rstate) + cmdPutStrLn $ plainText $ "Chatroom: " <> (fromMaybe "" $ roomName =<< roomStateRoom rstate) SelectedConversation conv -> do case conversationPeer conv of @@ -1084,7 +1083,7 @@ cmdDetails = do cmdPutStrLn $ "Contact:" prefix <- case contactCustomName contact of Just name -> do - cmdPutStrLn $ " " <> T.unpack name + cmdPutStrLn $ plainText $ " " <> name return $ Just "alias of" Nothing -> do return $ Nothing @@ -1101,11 +1100,11 @@ cmdDetails = do printIdentityDetailsBody prefix identity = do forM_ (zip (False : repeat True) $ unfoldOwners identity) $ \(owned, cpid) -> do - cmdPutStrLn $ unwords $ concat + cmdPutStrLn $ plainText $ T.unwords $ concat [ [ " " ] , if owned then [ "owned by" ] else maybeToList prefix - , [ maybe "" T.unpack (idName cpid) ] - , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid + , [ fromMaybe "" (idName cpid) ] + , map (T.decodeUtf8 . showRefDigest . refDigest . storedRef) $ idExtDataF cpid ] cmdDiscovery :: Command diff --git a/main/Terminal.hs b/main/Terminal.hs index 252a050..3e3864b 100644 --- a/main/Terminal.hs +++ b/main/Terminal.hs @@ -31,7 +31,6 @@ 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 @@ -372,21 +371,23 @@ hidePrompt term@Terminal {..} = do redrawPrompt term False -> return $ return () -printLine :: Terminal -> String -> IO TerminalLine +printLine :: Terminal -> FormattedText -> IO TerminalLine printLine tlTerminal@Terminal {..} str = do withMVar termLock $ \_ -> do - let strLines = lines str - tlLineCount = length strLines + let tlLineCount = formattedTextHeight str if termAnsi then do promptLine <- atomically $ do readTVar termShowPrompt >>= \case True -> getCurrentPromptLine tlTerminal False -> return "" - putAnsi $ "\r\ESC[K" <> fromString (unlines strLines) <> "\ESC[K" <> promptLine + putAnsi $ mconcat + [ AnsiText "\r\ESC[K", renderAnsiText $ endWithNewline str + , AnsiText "\ESC[K", promptLine + ] drawBottomLines tlTerminal else do - putStr $ unlines strLines + T.putStr $ renderPlainText $ endWithNewline str hFlush stdout return TerminalLine {..} diff --git a/src/Erebos/TextFormat.hs b/src/Erebos/TextFormat.hs index 88fe0c2..6674ebc 100644 --- a/src/Erebos/TextFormat.hs +++ b/src/Erebos/TextFormat.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Erebos.TextFormat ( FormattedText, plainText, @@ -8,8 +10,11 @@ module Erebos.TextFormat ( Color(..), setForegroundColor, setBackgroundColor, + endWithNewline, + renderPlainText, formattedTextLength, + formattedTextHeight, ) where import Data.Text (Text) @@ -35,14 +40,40 @@ setBackgroundColor :: Color -> TextStyle -> TextStyle setBackgroundColor color (CustomTextColor fg _) = CustomTextColor fg (Just color) +endWithNewline :: FormattedText -> FormattedText +endWithNewline = EndWithNewline + + renderPlainText :: FormattedText -> Text renderPlainText = \case PlainText text -> text ConcatenatedText ftexts -> mconcat $ map renderPlainText ftexts FormattedText _ ftext -> renderPlainText ftext + EndWithNewline ftext -> let res = renderPlainText ftext + in case T.unsnoc res of + Just ( _, '\n') -> res + _ -> res <> "\n" formattedTextLength :: FormattedText -> Int formattedTextLength = \case PlainText text -> T.length text ConcatenatedText ftexts -> sum $ map formattedTextLength ftexts FormattedText _ ftext -> formattedTextLength ftext + EndWithNewline ftext -> formattedTextLength ftext + +formattedTextHeight :: FormattedText -> Int +formattedTextHeight = countLines . collectParts + where + collectParts = \case + PlainText text -> [ text ] + ConcatenatedText ftexts -> concatMap collectParts ftexts + FormattedText _ ftext -> collectParts ftext + EndWithNewline ftext -> collectParts ftext + countLines (t : ts) + | T.null t = countLines ts + | otherwise = 1 + countLines (dropLine (t : ts)) + countLines [] = 0 + dropLine (t : ts) + | Just ( '\n', t' ) <- T.uncons (T.dropWhile (/= '\n') t) = t' : ts + | otherwise = dropLine ts + dropLine [] = [] diff --git a/src/Erebos/TextFormat/Ansi.hs b/src/Erebos/TextFormat/Ansi.hs index c0ff978..faec0ad 100644 --- a/src/Erebos/TextFormat/Ansi.hs +++ b/src/Erebos/TextFormat/Ansi.hs @@ -8,6 +8,8 @@ module Erebos.TextFormat.Ansi ( ) where import Control.Applicative +import Control.Monad.State +import Control.Monad.Writer import Data.String import Data.Text (Text) @@ -20,19 +22,38 @@ newtype AnsiText = AnsiText { fromAnsiText :: Text } deriving (Eq, Ord, Semigroup, Monoid, IsString) +data RenderState = RenderState + { rsEndedWithNewline :: Bool + } + +initialRenderState :: RenderState +initialRenderState = RenderState + { rsEndedWithNewline = True + } + renderAnsiText :: FormattedText -> AnsiText -renderAnsiText = AnsiText . go ( Nothing, Nothing ) +renderAnsiText ft = AnsiText $ T.concat $ execWriter $ flip evalStateT initialRenderState $ go ( Nothing, Nothing ) ft where + go :: ( Maybe Color, Maybe Color ) -> FormattedText -> StateT RenderState (Writer [ Text ]) () go cur@( cfg, cbg ) = \case - PlainText text -> text - ConcatenatedText ftexts -> mconcat $ map (go cur) ftexts - FormattedText (CustomTextColor fg bg) ftext -> mconcat - [ ansiColor fg bg - , go ( fg <|> cfg, bg <|> cbg ) ftext - , ansiColor + PlainText text -> do + tell [ text ] + case T.unsnoc text of + Just ( _, c ) -> modify (\s -> s { rsEndedWithNewline = c == '\n' }) + Nothing -> return () + ConcatenatedText ftexts -> mconcat <$> mapM (go cur) ftexts + FormattedText (CustomTextColor fg bg) ftext -> do + tell [ ansiColor fg bg ] + go ( fg <|> cfg, bg <|> cbg ) ftext + tell [ ansiColor (if fg /= cfg then cfg <|> Just DefaultColor else Nothing) (if bg /= cbg then cbg <|> Just DefaultColor else Nothing) - ] + ] + EndWithNewline ftext -> do + go cur ftext + gets rsEndedWithNewline >>= \case + True -> return () + False -> tell [ "\n" ] >> modify (\s -> s { rsEndedWithNewline = True }) ansiColor :: Maybe Color -> Maybe Color -> Text diff --git a/src/Erebos/TextFormat/Types.hs b/src/Erebos/TextFormat/Types.hs index a03bc71..a93026d 100644 --- a/src/Erebos/TextFormat/Types.hs +++ b/src/Erebos/TextFormat/Types.hs @@ -12,6 +12,7 @@ data FormattedText = PlainText Text | ConcatenatedText [ FormattedText ] | FormattedText TextStyle FormattedText + | EndWithNewline FormattedText instance IsString FormattedText where fromString = PlainText . fromString -- cgit v1.2.3