summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-01-15 19:53:40 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2023-01-16 21:13:22 +0100
commit29b263f350ea7dccb243ec28f6af7fc5c41f578e (patch)
treeb2b989436762bbf321693d92862ecfb0fddef656
parent6deeb46561c122f22bb289522520bc458636a796 (diff)
Haskeline for input handling
-rw-r--r--erebos-tester.cabal1
-rw-r--r--src/GDB.hs9
-rw-r--r--src/Main.hs4
-rw-r--r--src/Output.hs44
4 files changed, 21 insertions, 37 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index ed3d5a8..55866fc 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -67,6 +67,7 @@ executable erebos-tester-core
filepath ^>=1.4.2.1,
generic-deriving >=1.14 && <1.15,
Glob >=0.10 && <0.11,
+ haskeline >=0.8 && <0.9,
HsYAML >=0.2 && <0.3,
lens >=5.0 && <5.2,
megaparsec >=9.0 && <10,
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