From 29b263f350ea7dccb243ec28f6af7fc5c41f578e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 15 Jan 2023 19:53:40 +0100 Subject: Haskeline for input handling --- erebos-tester.cabal | 1 + src/GDB.hs | 9 ++------- src/Main.hs | 4 +--- src/Output.hs | 44 +++++++++++++++++--------------------------- 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 -- cgit v1.2.3