diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 7 | ||||
| -rw-r--r-- | src/Output.hs | 49 |
2 files changed, 41 insertions, 15 deletions
diff --git a/src/Main.hs b/src/Main.hs index 6cf5405..1a7e286 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -50,6 +50,7 @@ data Node = Node data Options = Options { optDefaultTool :: String , optProcTools :: [(ProcName, String)] + , optVerbose :: Bool , optTimeout :: Scientific , optGDB :: Bool } @@ -58,6 +59,7 @@ defaultOptions :: Options defaultOptions = Options { optDefaultTool = "" , optProcTools = [] + , optVerbose = False , optTimeout = 1 , optGDB = False } @@ -327,6 +329,9 @@ options = (pname, (_:path)) -> opts { optProcTools = (ProcName (T.pack pname), path) : optProcTools opts } ) "PATH") "test tool to be used" + , Option ['v'] ["verbose"] + (NoArg (\opts -> opts { optVerbose = True })) + "show output of processes and successful tests" , Option ['t'] ["timeout"] (ReqArg (\str opts -> case readMaybe str of Just timeout -> opts { optTimeout = timeout } @@ -348,5 +353,5 @@ main = do optDefaultTool opts `seq` return () - out <- startOutput + out <- startOutput $ optVerbose opts forM_ files $ mapM_ (runTest out opts) <=< parseTestFile diff --git a/src/Output.hs b/src/Output.hs index 2c34a7d..0bf757a 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -20,7 +20,14 @@ import System.IO import Test -data Output = Output { outState :: MVar OutputState } +data Output = Output + { outState :: MVar OutputState + , outConfig :: OutputConfig + } + +data OutputConfig = OutputConfig + { outVerbose :: Bool + } data OutputState = OutputState { outCurPrompt :: Maybe Text @@ -40,8 +47,10 @@ class MonadIO m => MonadOutput m where instance MonadIO m => MonadOutput (ReaderT Output m) where getOutput = ask -startOutput :: IO Output -startOutput = Output <$> newMVar OutputState { outCurPrompt = Nothing } +startOutput :: Bool -> IO Output +startOutput verbose = Output + <$> newMVar OutputState { outCurPrompt = Nothing } + <*> pure OutputConfig { outVerbose = verbose } outColor :: OutputType -> Text outColor OutputChildStdout = T.pack "0" @@ -61,6 +70,16 @@ outSign OutputMatch = T.pack "+" outSign OutputMatchFail = T.pack "/" outSign OutputError = T.pack "!!" +printWhenQuiet :: OutputType -> Bool +printWhenQuiet = \case + OutputChildStdout -> False + OutputChildStderr -> True + OutputChildInfo -> False + OutputChildFail -> True + OutputMatch -> False + OutputMatchFail -> True + OutputError -> True + clearPrompt :: OutputState -> IO () clearPrompt OutputState { outCurPrompt = Just _ } = T.putStr $ T.pack "\ESC[2K\r" clearPrompt _ = return () @@ -73,17 +92,19 @@ ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a ioWithOutput act = liftIO . act =<< getOutput outLine :: MonadOutput m => OutputType -> Maybe ProcName -> Text -> m () -outLine otype mbproc line = ioWithOutput $ \out -> withMVar (outState out) $ \st -> do - clearPrompt st - TL.putStrLn $ TL.fromChunks - [ T.pack "\ESC[", outColor otype, T.pack "m" - , maybe T.empty textProcName mbproc - , outSign otype - , T.pack "> " - , line - , T.pack "\ESC[0m" - ] - showPrompt st +outLine otype mbproc 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" + , maybe T.empty textProcName mbproc + , outSign otype + , T.pack "> " + , line + , T.pack "\ESC[0m" + ] + showPrompt st outPrompt :: MonadOutput m => Text -> m () outPrompt p = ioWithOutput $ \out -> modifyMVar_ (outState out) $ \st -> do |