From 9678331ed60bd487547c07e369aa5a06252d0954 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 19 Jan 2025 19:32:53 +0100
Subject: Custom prompt implementation instead of Haskeline
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Changelog: New CLI prompt implementation providing cleaner interface
Changelog: CLI: Avoids displaying sent messages twice – both in previous prompt and in message history
---
 main/Main.hs | 37 +++++++++++++++++++------------------
 1 file changed, 19 insertions(+), 18 deletions(-)

(limited to 'main/Main.hs')

diff --git a/main/Main.hs b/main/Main.hs
index fa2b4c1..528b8c2 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -31,7 +31,6 @@ import Data.Typeable
 import Network.Socket
 
 import System.Console.GetOpt
-import System.Console.Haskeline
 import System.Environment
 import System.Exit
 import System.IO
@@ -57,6 +56,7 @@ import Erebos.Storage
 import Erebos.Storage.Merge
 import Erebos.Sync
 
+import Terminal
 import Test
 import Version
 
@@ -243,22 +243,20 @@ main = do
             exitFailure
 
 
-inputSettings :: Settings IO
-inputSettings = setComplete commandCompletion $ defaultSettings
-
 interactiveLoop :: Storage -> Options -> IO ()
-interactiveLoop st opts = runInputT inputSettings $ do
+interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
     erebosHead <- liftIO $ loadLocalStateHead st
-    outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
+    void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
 
-    tui <- haveTerminalUI
-    extPrint <- getExternalPrint
+    let tui = hasTerminalUI term
+    let extPrint = void . printLine term
     let extPrintLn str = do
             let str' = case reverse str of ('\n':_) -> str
                                            _ -> str ++ "\n";
             extPrint $! str' -- evaluate str before calling extPrint to avoid blinking
 
-    let getInputLinesTui eprompt = do
+    let getInputLinesTui :: Either CommandState String -> MaybeT IO String
+        getInputLinesTui eprompt = do
             prompt <- case eprompt of
                 Left cstate -> do
                     pname <- case csContext cstate of
@@ -272,11 +270,14 @@ interactiveLoop st opts = runInputT inputSettings $ do
                         SelectedConversation conv -> return $ T.unpack $ conversationName conv
                     return $ pname ++ "> "
                 Right prompt -> return prompt
-            Just input <- lift $ getInputLine prompt
-            case reverse input of
-                 _ | all isSpace input -> getInputLinesTui eprompt
-                 '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ")
-                 _         -> return input
+            lift $ setPrompt term prompt
+            join $ lift $ getInputLine term $ \case
+                Just input@('/' : _) -> KeepPrompt $ return input
+                Just input -> ErasePrompt $ case reverse input of
+                    _ | all isSpace input -> getInputLinesTui eprompt
+                    '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ")
+                    _         -> return input
+                Nothing -> KeepPrompt mzero
 
         getInputCommandTui cstate = do
             input <- getInputLinesTui cstate
@@ -289,7 +290,7 @@ interactiveLoop st opts = runInputT inputSettings $ do
             return (cmd, line)
 
         getInputLinesPipe = do
-            lift (getInputLine "") >>= \case
+            join $ lift $ getInputLine term $ KeepPrompt . \case
                 Just input -> return input
                 Nothing -> liftIO $ forever $ threadDelay 100000000
 
@@ -350,12 +351,12 @@ interactiveLoop st opts = runInputT inputSettings $ do
                 when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown
             _ -> return ()
 
-    let process :: CommandState -> MaybeT (InputT IO) CommandState
+    let process :: CommandState -> MaybeT IO CommandState
         process cstate = do
             (cmd, line) <- getInputCommand cstate
             h <- liftIO (reloadHead $ csHead cstate) >>= \case
                 Just h  -> return h
-                Nothing -> do lift $ lift $ extPrintLn "current head deleted"
+                Nothing -> do lift $ extPrintLn "current head deleted"
                               mzero
             res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput
                 { ciServer = server
@@ -375,7 +376,7 @@ interactiveLoop st opts = runInputT inputSettings $ do
                     | csQuit cstate' -> mzero
                     | otherwise      -> return cstate'
                 Left err -> do
-                    lift $ lift $ extPrintLn $ "Error: " ++ err
+                    lift $ extPrintLn $ "Error: " ++ err
                     return cstate
 
     let loop (Just cstate) = runMaybeT (process cstate) >>= loop
-- 
cgit v1.2.3