From 29b263f350ea7dccb243ec28f6af7fc5c41f578e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 15 Jan 2023 19:53:40 +0100
Subject: Haskeline for input handling

---
 src/GDB.hs    |  9 ++-------
 src/Main.hs   |  4 +---
 src/Output.hs | 44 +++++++++++++++++---------------------------
 3 files changed, 20 insertions(+), 37 deletions(-)

(limited to 'src')

diff --git a/src/GDB.hs b/src/GDB.hs
index f360637..3c60457 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -17,13 +17,11 @@ import Data.Char
 import Data.List
 import Data.Text (Text)
 import Data.Text qualified as T
-import Data.Text.IO qualified as T
 import Data.Void
 
 import Text.Megaparsec hiding (State)
 import Text.Megaparsec.Char
 
-import System.IO.Error
 import System.Process
 
 import Output
@@ -175,12 +173,9 @@ gdbCommand gdb cmd = do
         (Exit, _) -> outProc OutputError (gdbProcess gdb) "result exit"
 
 gdbSession :: MonadOutput m => GDB -> m ()
-gdbSession gdb = do
-    outPrompt "gdb> "
-    loop ""
-    outClearPrompt
+gdbSession gdb = loop ""
   where
-    loop prev = liftIO (catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e)) >>= \case
+    loop prev = outPromptGetLine "gdb> " >>= \case
         Just line -> do
             let cmd = if T.null line then prev else line
             gdbCommand gdb ("-interpreter-exec console \"" <> cmd <> "\"")
diff --git a/src/Main.hs b/src/Main.hs
index 64edf7e..e9e3c4c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -218,9 +218,7 @@ evalSteps = mapM_ $ \case
         withNodePacketLoss n l $ evalSteps inner
 
     Wait -> do
-        outPrompt $ T.pack "Waiting..."
-        void $ liftIO $ getLine
-        outClearPrompt
+        void $ outPromptGetLine "Waiting..."
 
 runTest :: Output -> TestOptions -> Test -> IO Bool
 runTest out opts test = do
diff --git a/src/Output.hs b/src/Output.hs
index 3b0585e..412e7b4 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -5,7 +5,7 @@ module Output (
     MonadOutput(..),
     startOutput,
     outLine,
-    outPrompt, outClearPrompt,
+    outPromptGetLine,
 ) where
 
 import Control.Concurrent.MVar
@@ -14,11 +14,10 @@ import Control.Monad.Reader
 
 import Data.Text (Text)
 import Data.Text qualified as T
-import Data.Text.IO qualified as T
 import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.IO qualified as TL
 
-import System.IO
+import System.Console.Haskeline
 
 data Output = Output
     { outState :: MVar OutputState
@@ -31,6 +30,7 @@ data OutputConfig = OutputConfig
 
 data OutputState = OutputState
     { outCurPrompt :: Maybe Text
+    , outPrint :: TL.Text -> IO ()
     }
 
 data OutputType = OutputChildStdout
@@ -51,7 +51,7 @@ instance MonadIO m => MonadOutput (ReaderT Output m) where
 
 startOutput :: Bool -> IO Output
 startOutput verbose = Output
-    <$> newMVar OutputState { outCurPrompt = Nothing }
+    <$> newMVar OutputState { outCurPrompt = Nothing, outPrint = TL.putStrLn }
     <*> pure OutputConfig { outVerbose = verbose }
 
 outColor :: OutputType -> Text
@@ -89,14 +89,6 @@ printWhenQuiet = \case
     OutputAlways -> True
     _ -> False
 
-clearPrompt :: OutputState -> IO ()
-clearPrompt OutputState { outCurPrompt = Just _ } = T.putStr $ T.pack "\ESC[2K\r"
-clearPrompt _ = return ()
-
-showPrompt :: OutputState -> IO ()
-showPrompt OutputState { outCurPrompt = Just p } = T.putStr p >> hFlush stdout
-showPrompt _ = return ()
-
 ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a
 ioWithOutput act = liftIO . act =<< getOutput
 
@@ -104,23 +96,21 @@ outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m ()
 outLine otype prompt line = ioWithOutput $ \out ->
     when (outVerbose (outConfig out) || printWhenQuiet otype) $ do
         withMVar (outState out) $ \st -> do
-            clearPrompt st
-            TL.putStrLn $ TL.fromChunks
+            outPrint st $ TL.fromChunks
                 [ T.pack "\ESC[", outColor otype, T.pack "m"
                 , maybe "" (<> outSign otype <> outArr otype <> " ") prompt
                 , line
                 , T.pack "\ESC[0m"
                 ]
-            showPrompt st
-
-outPrompt :: MonadOutput m => Text -> m ()
-outPrompt p = ioWithOutput $ \out -> modifyMVar_ (outState out) $ \st -> do
-    clearPrompt st
-    let st' = st { outCurPrompt = Just p }
-    showPrompt st'
-    return st'
-
-outClearPrompt :: MonadOutput m => m ()
-outClearPrompt = ioWithOutput $ \out -> modifyMVar_ (outState out) $ \st -> do
-    clearPrompt st
-    return st { outCurPrompt = Nothing }
+
+outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text)
+outPromptGetLine prompt = ioWithOutput $ \out -> do
+    st <- takeMVar (outState out)
+    (x, st') <- runInputT defaultSettings $ do
+        p <- getExternalPrint
+        liftIO $ putMVar (outState out) st { outPrint = p . TL.unpack . (<>"\n") }
+        x <- getInputLine $ T.unpack prompt
+        st' <- liftIO $ takeMVar (outState out)
+        return (x, st' { outPrint = outPrint st })
+    putMVar (outState out) st'
+    return $ fmap T.pack x
-- 
cgit v1.2.3