summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-10-27 21:56:22 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-10-27 21:56:22 +0200
commit86351a85ec5c92a390e7bfc70648a67be84619c0 (patch)
tree856b21d62b372ed5e6e64cf105d6f34c860a1965
parent3e70d73d4499689840596598ea943296a34b53ab (diff)
Show GDB console output always and without prompt
-rw-r--r--src/GDB.hs2
-rw-r--r--src/Main.hs8
-rw-r--r--src/Output.hs12
-rw-r--r--src/Process.hs2
4 files changed, 14 insertions, 10 deletions
diff --git a/src/GDB.hs b/src/GDB.hs
index 75f42fe..8cd6e10 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -132,7 +132,7 @@ gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . erro
, Just (MiString tgid) <- lookup "group-id" params
-> liftIO $ modifyMVar_ (gdbInferiors gdb) $ return . map (\inf -> if infThreadGroup inf == tgid then inf { infThreads = filter (/=tid) $ infThreads inf } else inf)
_ -> return ()
- ConsoleStreamOutput line -> mapM_ (outProc OutputChildStdout (gdbProcess gdb)) (T.lines line)
+ ConsoleStreamOutput line -> mapM_ (outLine OutputAlways Nothing) (T.lines line)
TargetStreamOutput line -> mapM_ (outProc OutputChildStderr (gdbProcess gdb) . ("target-stream: " <>)) (T.lines line)
LogStreamOutput line -> mapM_ (outProc OutputChildInfo (gdbProcess gdb) . ("log: " <>)) (T.lines line)
diff --git a/src/Main.hs b/src/Main.hs
index 9d2f9cc..d293226 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -72,7 +72,7 @@ newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (Excep
instance MonadFail TestRun where
fail str = do
- outLine OutputError T.empty $ T.pack str
+ outLine OutputError Nothing $ T.pack str
throwError Failed
instance MonadError Failed TestRun where
@@ -249,9 +249,9 @@ exprFailed :: Text -> SourceLine -> Maybe ProcName -> Expr a -> TestRun ()
exprFailed desc (SourceLine sline) pname expr = do
let prompt = maybe T.empty textProcName pname
exprVars <- gatherVars expr
- outLine OutputMatchFail prompt $ T.concat [desc, T.pack " failed on ", sline]
+ outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline]
forM_ exprVars $ \(name, value) ->
- outLine OutputMatchFail prompt $ T.concat [T.pack " ", textVarName name, T.pack " = ", textSomeVarValue value]
+ outLine OutputMatchFail (Just prompt) $ T.concat [T.pack " ", textVarName name, T.pack " = ", textSomeVarValue value]
throwError Failed
expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun ()
@@ -301,7 +301,7 @@ evalSteps = mapM_ $ \case
Let (SourceLine sline) name expr inner -> do
cur <- asks (lookup name . tsVars . snd)
when (isJust cur) $ do
- outLine OutputError T.empty $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
+ outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
throwError Failed
value <- eval expr
withVar name value $ evalSteps inner
diff --git a/src/Output.hs b/src/Output.hs
index ca7f862..661e4fc 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Output (
Output, OutputType(..),
MonadOutput(..),
@@ -38,6 +40,7 @@ data OutputType = OutputChildStdout
| OutputMatch
| OutputMatchFail
| OutputError
+ | OutputAlways
class MonadIO m => MonadOutput m where
getOutput :: m Output
@@ -58,6 +61,7 @@ outColor OutputChildFail = T.pack "31"
outColor OutputMatch = T.pack "32"
outColor OutputMatchFail = T.pack "31"
outColor OutputError = T.pack "31"
+outColor OutputAlways = "0"
outSign :: OutputType -> Text
outSign OutputChildStdout = T.empty
@@ -67,6 +71,7 @@ outSign OutputChildFail = T.pack "!!"
outSign OutputMatch = T.pack "+"
outSign OutputMatchFail = T.pack "/"
outSign OutputError = T.pack "!!"
+outSign OutputAlways = T.empty
printWhenQuiet :: OutputType -> Bool
printWhenQuiet = \case
@@ -77,6 +82,7 @@ printWhenQuiet = \case
OutputMatch -> False
OutputMatchFail -> True
OutputError -> True
+ OutputAlways -> True
clearPrompt :: OutputState -> IO ()
clearPrompt OutputState { outCurPrompt = Just _ } = T.putStr $ T.pack "\ESC[2K\r"
@@ -89,16 +95,14 @@ showPrompt _ = return ()
ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a
ioWithOutput act = liftIO . act =<< getOutput
-outLine :: MonadOutput m => OutputType -> Text -> Text -> m ()
+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
[ T.pack "\ESC[", outColor otype, T.pack "m"
- , prompt
- , outSign otype
- , T.pack "> "
+ , maybe "" (<> outSign otype <> "> ") prompt
, line
, T.pack "\ESC[0m"
]
diff --git a/src/Process.hs b/src/Process.hs
index de834a5..8548e73 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -68,7 +68,7 @@ send p line = liftIO $ do
hFlush (procStdin p)
outProc :: MonadOutput m => OutputType -> Process -> Text -> m ()
-outProc otype p line = outLine otype (textProcName $ procName p) line
+outProc otype p line = outLine otype (Just $ textProcName $ procName p) line
lineReadingLoop :: MonadOutput m => Process -> Handle -> (Text -> m ()) -> m ()
lineReadingLoop process h act =