diff options
| -rw-r--r-- | src/GDB.hs | 2 | ||||
| -rw-r--r-- | src/Main.hs | 8 | ||||
| -rw-r--r-- | src/Output.hs | 12 | ||||
| -rw-r--r-- | src/Process.hs | 2 |
4 files changed, 14 insertions, 10 deletions
@@ -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 = |