diff --git a/src-hxbrief/Main.hs b/src-hxbrief/Main.hs index 98eaa43..7cf6dc2 100644 --- a/src-hxbrief/Main.hs +++ b/src-hxbrief/Main.hs @@ -93,14 +93,17 @@ data StreamKind = StdOut | StdErr deriving (Eq, Show) data JoinMode - = JoinYield -- i.e. don't join: We want to yield that exact line - | JoinAll -- join with any other JoinAll-tagged lines/patterns + = JoinYield -- don't join: We want to yield that exact line + | JoinDrop -- don't join, and drop the line from the summary + | JoinAllKeep -- join with any other JoinAll-tagged lines/patterns, override headers + | JoinAllDrop -- join with any other JoinAll-tagged lines/patterns, drop before headers, dont output | JoinSpecific -- join with this pattern only + | JoinHeader -- join with nothing, stays, only gets replaced by next yield/header data JoinedInfo - = JoinedNot -- Line did not match any pattern - | JoinedYield -- Line matched a yield pattern, must be forwarded as-is - | JoinedAll Int + = JoinedNot Bool -- yield or drop, not to be merged. bool determines whether to forward + | JoinedHeader Bool Int Int -- header, not to be merged. bool determines whether to forward. Int is count stdout/stderr + | JoinedAll Bool Int -- bool determines whether to forward | Joined Int Text [Text] -- pattern, prefix data KeepMode @@ -226,6 +229,25 @@ dispatchPat oldKind i pat prefix = do StdOut -> when (c_keepStdout conf /= Drop) $ outputConcurrent prettyPat StdErr -> when (c_keepStderr conf /= Drop) $ errorConcurrent prettyPat +showHeader :: Text -> Int -> Int -> Text +showHeader header countOut countErr = + header + <> fGrey + <> t " (" + <> t (show countOut) + <> t "/" + <> t (show countErr) + <> t " lines out/err)" + <> fReset + +dispatchHeader :: StreamKind -> Int -> Int -> Text -> StateT State IO () +dispatchHeader oldKind countOut countErr header = do + let prettyPat = showHeader header countOut countErr <> t "\n" + conf <- gets s_config + liftIO $ case oldKind of + StdOut -> when (c_keepStdout conf /= Drop) $ outputConcurrent prettyPat + StdErr -> when (c_keepStderr conf /= Drop) $ errorConcurrent prettyPat + dispatchSkipped :: StreamKind -> Int -> StateT State IO () dispatchSkipped oldKind i = do let kindStr = case oldKind of @@ -250,102 +272,140 @@ summarizeLines :: (StreamKind, Text, Float) -> StateT State IO () summarizeLines (kind, line, _linetime) = do s <- get let conf = s_config s - let match :: Maybe (JoinMode, Text) = + let match :: (JoinMode, Text) = case - firstJust + ( firstJust (\(mode, pat, regex) -> if Regex.matchTest regex line then Just (mode, pat) else Nothing ) (c_summarize conf) + , kind + ) of - j@Just{} -> j - Nothing | kind == StdOut && c_keepStdout conf == Conflate -> - Just (JoinAll, t "*") - Nothing | kind == StdErr && c_keepStderr conf == Conflate -> - Just (JoinAll, t "*") - Nothing -> Nothing + (Just j , _ ) -> j + (Nothing, StdOut) -> case c_keepStdout conf of + Conflate -> (JoinAllKeep, t "*") + Keep -> (JoinYield, t "*") + Drop -> (JoinDrop, t "*") + (Nothing, StdErr) -> case c_keepStderr conf of + Conflate -> (JoinAllKeep, t "*") + Keep -> (JoinYield, t "*") + Drop -> (JoinDrop, t "*") case (s_summary s, match) of (Nothing, _) -> put s { s_summary = Just - ( kind - , line - , case match of - Nothing -> JoinedNot - Just (JoinYield , _ ) -> JoinedYield - Just (JoinAll , _ ) -> JoinedAll 1 - Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) - ) + ( kind + , line + , case match of + (JoinYield , _ ) -> JoinedNot True + (JoinAllKeep , _ ) -> JoinedAll True 1 + (JoinAllDrop , _ ) -> JoinedAll False 1 + (JoinSpecific, pat) -> Joined 1 pat (Text.words line) + (JoinHeader , _ ) -> JoinedHeader False 0 0 + (JoinDrop , _ ) -> JoinedNot False + ) } - (Just (oldKind, oldLine, JoinedNot), _) -> do - dispatchLine (oldKind, oldLine) + -- (Just (oldKind, oldLine, JoinedNot), _) -> do + -- dispatchLine (oldKind, oldLine) + -- put s + -- { s_summary = Just + -- ( kind + -- , line + -- , case match of + -- Nothing -> JoinedNot + -- Just (JoinYield , _ ) -> JoinedYield + -- Just (JoinAllKeep , _ ) -> JoinedAll True 1 + -- Just (JoinAllDrop , _ ) -> JoinedAll False 1 + -- Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) + -- Just (JoinHeader , _ ) -> JoinedHeader + -- ) + -- } + (Just (oldKind, oldLine, JoinedNot keep), joiner) -> do + when keep $ dispatchYielded (oldKind, oldLine) put s - { s_summary = Just - ( kind - , line - , case match of - Nothing -> JoinedNot - Just (JoinYield , _ ) -> JoinedYield - Just (JoinAll , _ ) -> JoinedAll 1 - Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) - ) + { s_summary = case joiner of + (JoinYield , _pat) -> Just (kind, line, JoinedNot True) + (JoinAllKeep, _ ) -> Just (kind, line, JoinedAll True 1) + (JoinAllDrop, _ ) -> Just (kind, line, JoinedAll False 1) + (JoinSpecific, pat) -> + Just (kind, line, Joined 1 pat (Text.words line)) + (JoinHeader, _) -> Just (kind, line, JoinedHeader False 0 0) + (JoinDrop , _) -> Just (kind, line, JoinedNot False) } - (Just (oldKind, oldLine, JoinedYield), Nothing) -> do - dispatchYielded (oldKind, oldLine) - put s { s_summary = Just (kind, line, JoinedNot) } - (Just (oldKind, oldLine, JoinedYield), _) -> do - dispatchYielded (oldKind, oldLine) - put s - { s_summary = Just - ( kind - , line - , case match of - Nothing -> JoinedNot - Just (JoinAll , _ ) -> JoinedAll 1 - Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) - Just (JoinYield , _ ) -> JoinedYield - ) - } - (Just (oldKind, _, JoinedAll i), Nothing) -> do - dispatchSkipped oldKind i - put s { s_summary = Just (kind, line, JoinedNot) } - (Just (oldKind, _, Joined i oldPat oldPrefix), Nothing) -> do - dispatchPat oldKind i oldPat oldPrefix - put s { s_summary = Just (kind, line, JoinedNot) } - (Just (oldKind, _, JoinedAll i), Just joiner) -> case joiner of + (Just (oldKind, oldLine, JoinedHeader keep countOut countErr), joiner) -> + do + let replaceMay = case joiner of + (JoinYield , _pat) -> Just (JoinedNot True) + (JoinAllKeep , _ ) -> Just (JoinedAll True 1) + (JoinAllDrop , _ ) -> Nothing + (JoinSpecific, pat ) -> Just (Joined 1 pat (Text.words line)) + (JoinHeader , _ ) -> Just (JoinedHeader False 0 0) + (JoinDrop , _ ) -> Nothing + case replaceMay of + Just replace -> do + when keep $ dispatchHeader oldKind countOut countErr oldLine + put s { s_summary = Just (kind, line, replace) } + Nothing -> do + put s + { s_summary = Just + ( oldKind + , oldLine + , case kind of + StdOut -> + JoinedHeader keep (countOut + 1) countErr + StdErr -> + JoinedHeader keep countOut (countErr + 1) + ) + } + (Just (oldKind, _, JoinedAll keep i), joiner) -> case joiner of (JoinYield, _pat) -> do - dispatchSkipped oldKind i - put s { s_summary = Just (kind, line, JoinedYield) } - (JoinAll, _) + when keep $ dispatchSkipped oldKind i + put s { s_summary = Just (kind, line, JoinedNot True) } + (JoinAllKeep, _) | kind == oldKind -> do - put s { s_summary = Just (kind, line, JoinedAll (i + 1)) } + put s { s_summary = Just (kind, line, JoinedAll True (i + 1)) } | otherwise -> do - dispatchSkipped oldKind i - put s { s_summary = Just (kind, line, JoinedAll 1) } + when keep $ dispatchSkipped oldKind i + put s { s_summary = Just (kind, line, JoinedAll True 1) } + (JoinAllDrop, _) + | kind == oldKind -> do + put s { s_summary = Just (kind, line, JoinedAll False (i + 1)) } + | otherwise -> do + when keep $ dispatchSkipped oldKind i + put s { s_summary = Just (kind, line, JoinedAll False 1) } (JoinSpecific, pat) -> do dispatchSkipped oldKind i put s { s_summary = Just (kind, line, Joined 1 pat (Text.words line)) } - (Just (oldKind, _, Joined i oldPat oldPrefix), Just joiner) -> - case joiner of - (JoinSpecific, pat) | oldPat == pat && kind == oldKind -> do - let newPrefix = - let go [] = [] - go ((a, b) : rest) | a == b = a : go rest - | otherwise = [] - in go $ zip oldPrefix (Text.words line) - put s { s_summary = Just (kind, line, Joined (i + 1) pat newPrefix) } - _ -> do - dispatchPat oldKind i oldPat oldPrefix - put s - { s_summary = Just - ( kind - , line - , case joiner of - (JoinYield , _ ) -> JoinedYield - (JoinAll , _ ) -> JoinedAll 1 - (JoinSpecific, pat) -> Joined 1 pat (Text.words line) - ) - } + (JoinHeader, _) -> do + dispatchSkipped oldKind i + put s { s_summary = Just (kind, line, JoinedHeader False 0 0) } + (JoinDrop, _) -> do + dispatchSkipped oldKind i + put s { s_summary = Just (kind, line, JoinedNot False) } + (Just (oldKind, _, Joined i oldPat oldPrefix), joiner) -> case joiner of + (JoinSpecific, pat) | oldPat == pat && kind == oldKind -> do + let newPrefix = + let go [] = [] + go ((a, b) : rest) | a == b = a : go rest + | otherwise = [] + in go $ zip oldPrefix (Text.words line) + put s { s_summary = Just (kind, line, Joined (i + 1) pat newPrefix) } + _ -> do + dispatchPat oldKind i oldPat oldPrefix + put s + { s_summary = Just + ( kind + , line + , case joiner of + (JoinYield , _ ) -> JoinedNot True + (JoinAllKeep , _ ) -> JoinedAll True 1 + (JoinAllDrop , _ ) -> JoinedAll False 1 + (JoinSpecific, pat) -> Joined 1 pat (Text.words line) + (JoinHeader , _ ) -> JoinedHeader False 0 0 + (JoinDrop , _ ) -> JoinedNot False + ) + } prettyLine :: Config -> (StreamKind, Text, Float) -> Text @@ -393,11 +453,17 @@ processLine newKind newLine = execStateT $ do summary <- gets s_summary pure $ case summary of Nothing -> prettyLines - Just (StdOut, line, JoinedNot) -> + Just (StdOut, line, JoinedNot _) -> (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines - Just (StdOut, line, JoinedAll 1) -> + Just (StdOut, line, JoinedHeader _ countOut countErr) -> + (fWhiteDis <> t "│ " <> fReset <> ellipse + conf + (showHeader line countOut countErr) + ) + : prettyLines + Just (StdOut, line, JoinedAll _ 1) -> (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines - Just (StdOut, _line, JoinedAll i) -> + Just (StdOut, _line, JoinedAll _ i) -> ( fWhiteDis <> t "│ " <> fGrey @@ -421,15 +487,17 @@ processLine newKind newLine = execStateT $ do <> fReset ) : prettyLines - Just (StdOut, line, JoinedYield) -> - (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines - Just (StdErr, line, JoinedNot) -> + Just (StdErr, line, JoinedNot _) -> (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines - Just (StdErr, line, JoinedYield) -> + Just (StdErr, line, JoinedHeader _ countOut countErr) -> + (fRedDis <> t "│ " <> fReset <> ellipse + conf + (showHeader line countOut countErr) + ) + : prettyLines + Just (StdErr, line, JoinedAll _ 1) -> (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines - Just (StdErr, line, JoinedAll 1) -> - (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines - Just (StdErr, _line, JoinedAll i) -> + Just (StdErr, _line, JoinedAll _ i) -> ( fRedDis <> t "│ " <> fGrey @@ -506,69 +574,73 @@ updateStateLine = do quoteIfSpaces :: String -> String quoteIfSpaces s = if any Char.isSpace s then "\"" ++ s ++ "\"" else s +-- brittany-next-binding --columns 180 main :: IO () main = B.mainFromCmdParser $ do B.reorderStart + -- For both stdout and stderr, each line flow through multiple stages. + -- In the console UI, lines "flow" from bottom of the screen upwards. + -- Lets image we run over the canonical "fizzbuzz" linewise output: + -- -- 1, 2, Fizz, 4, Buzz, Fizz, 7, 8, Fizz, Buzz, 11, Fizz, 13, 14, Fizz Buzz, 16, 17, Fizz, 19, Buzz, Fizz, 22, 23, Fizz, Buzz, 26, Fizz, 28, 29, Fizz Buzz, 31, 32, Fizz, 34, Buzz, Fizz, ... + -- We configure to 2 live lines + summary, summarizing lines that contain + -- numbers, yielding lines that contain Fizz/Buzz. + -- Time flows from left to right: + -- (you can see this live by running:) + -- > hxbrief --drop --yield "Fizz|Buzz" -s "[0-9]" -n3 -- ./sample-fizzbuzz.sh + -- t0 t1 t2 t3 t4 t5 t6 t7 t8 Line class + -- .... -forwarded- + -- Fizz Buzz -forwarded- + -- Fizz Fizz Buzz Fizz -forwarded- + -- | 1 | %d+ | Fizz | 4 | Buzz | Fizz | 7 -summary- + -- | 1 | 2 | Fizz | 4 | Buzz | Fizz | 7 | 8 -live- + -- | 1 | 2 | Fizz | 4 | Buzz | Fizz | 7 | 8 | Fizz -live- + -- + -- As you can see, lines flow from being the output of our fizzbuzz into our + -- live display, into the summary, into the forwarded. At each step, we can + -- filter/merge lines, i.e. + -- + -- input --------> live --------------> summary --------> forwarded + -- filter f1 filter/merge f2 filter f3 + -- + -- f1/f2/f3 together determine how far each line "travels". hxbrief allows + -- configuring a) a default behaviour b) a list of (regex, behaviour) pairs + -- that control how any particular input line is handled. + -- behaviour | matching lines ... + -- 1) discard | are filtered out at f1. All other pass f1. + -- 2) drop | are filtered out at f2. + -- 3) conflate | combine with any other lines with this behaviour + -- 4) group | combine with lines that matched the same pattern, get filtered at f3 + -- 5) summary | combine with lines that matched the same pattern, pass f3 + -- 6) header | always replace the current summary, get filtered out at f3 + -- 7) yield | always replace the current summary, pass f3 + + + + + numLines :: Int <- B.addFlagReadParam "n" ["lines"] "LINES" (B.flagDefault 5) maxLines <- B.addSimpleBoolFlag "" ["max-lines"] mempty keepStdout <- B.addSimpleBoolFlag "" ["keep-out"] mempty keepStderr <- B.addSimpleBoolFlag "" ["keep-err"] mempty - keepBoth <- B.addSimpleBoolFlag "" ["keep"] mempty + keepBoth <- B.addSimpleBoolFlag "" ["keep-all"] mempty dropStdout <- B.addSimpleBoolFlag "" ["drop-out"] mempty dropStderr <- B.addSimpleBoolFlag "" ["drop-err"] mempty - dropBoth <- B.addSimpleBoolFlag "" ["drop"] mempty + dropBoth <- B.addSimpleBoolFlag "" ["drop-all"] mempty conflateStdout <- B.addSimpleBoolFlag "" ["conflate-out"] mempty conflateStderr <- B.addSimpleBoolFlag "" ["conflate-err"] mempty - conflateBoth <- B.addSimpleBoolFlag "" ["conflate"] mempty - summarize <- B.addFlagStringParams - "s" - ["summarize"] - "REGEX" - (B.flagHelpStr "bundle lines starting with this pattern into one line") - summarizeFull <- B.addFlagStringParams - "" - ["summarize-any"] - "REGEX" - (B.flagHelpStr "bundle lines containing this pattern into one line") - skip <- B.addFlagStringParams - "x" - ["skip"] - "REGEX" - (B.flagHelpStr "drop lines starting with this pattern, similar to `grep -v`" - ) - skipFull <- B.addFlagStringParams - "" - ["skip-any"] - "REGEX" - (B.flagHelpStr "drop lines containing this pattern, similar to `grep -v`") - label <- B.addFlagStringParams "" ["label"] "STRING" mempty - yield <- B.addFlagStringParams - "y" - ["yield"] - "REGEX" - (B.flagHelpStr - "always fully retain lines starting with this pattern, disregarding skip/summarize" - ) - yieldFull <- B.addFlagStringParams - "" - ["yield-any"] - "REGEX" - (B.flagHelpStr - "always fully retain lines containing this pattern, disregarding skip/summarize" - ) - omitSummary <- B.addSimpleBoolFlag "" ["omit-summary"] mempty - tee <- B.addFlagStringParams - "" - ["tee"] - "BASENAMEBASEPATH" - ( B.flagHelp - $ PP.text "Write copy of stdout/stderr to BASEPATH.{out/err}.txt" - ) - teeBoth <- B.addFlagStringParams - "" - ["tee-both"] - "FILENAMEFILEPATH" - (B.flagHelp $ PP.text "Write copy of stdout and stderr to FILEPATH") + conflateBoth <- B.addSimpleBoolFlag "" ["conflate-all"] mempty + summarize <- B.addFlagStringParams "s" ["summarize"] "REGEX" (B.flagHelpStr "bundle lines starting with this pattern into one line") + summarizeFull <- B.addFlagStringParams "" ["summarize-any"] "REGEX" (B.flagHelpStr "bundle lines containing this pattern into one line") + dropArg <- B.addFlagStringParams "x" ["drop"] "REGEX" (B.flagHelpStr "drop lines starting with this pattern, similar to `grep -v`") + dropFull <- B.addFlagStringParams "" ["drop-any"] "REGEX" (B.flagHelpStr "drop lines containing this pattern, similar to `grep -v`") + label <- B.addFlagStringParams "" ["label"] "STRING" mempty + yield <- B.addFlagStringParams "y" ["yield"] "REGEX" (B.flagHelpStr "always fully retain lines starting with this pattern, disregarding skip/summarize") + yieldFull <- B.addFlagStringParams "" ["yield-any"] "REGEX" (B.flagHelpStr "always fully retain lines containing this pattern, disregarding skip/summarize") + header <- B.addFlagStringParams "h" ["header"] "REGEX" (B.flagHelpStr "starting with this pattern: always replaces summary, then gets dropped") + headerFull <- B.addFlagStringParams "" ["header-any"] "REGEX" (B.flagHelpStr "containing this pattern: always replaces summary, then gets dropped") + omitSummary <- B.addSimpleBoolFlag "" ["omit-summary"] mempty + tee <- B.addFlagStringParams "" ["tee"] "BASENAMEBASEPATH" (B.flagHelp $ PP.text "Write copy of stdout/stderr to BASEPATH.{out/err}.txt") + teeBoth <- B.addFlagStringParams "" ["tee-both"] "FILENAMEFILEPATH" (B.flagHelp $ PP.text "Write copy of stdout and stderr to FILEPATH") -- section <- B.addSimpleBoolFlag "" ["section"] mempty B.reorderStop rest <- B.addParamRestOfInputRaw "COMMAND" mempty <&> \case @@ -625,24 +697,13 @@ main = B.mainFromCmdParser $ do envLines <- System.Environment.lookupEnv "LINES" envCols <- System.Environment.lookupEnv "COLUMNS" pure $ (,) <$> (envLines >>= readMaybe) <*> (envCols >>= readMaybe) - let stdoutCheckCount = - length - $ [ () | keepStdout || keepBoth ] - ++ [ () | conflateStdout || conflateBoth ] - ++ [ () | dropStdout || dropBoth ] - let stderrCheckCount = - length - $ [ () | keepStderr || keepBoth ] - ++ [ () | conflateStderr || conflateBoth ] - ++ [ () | dropStderr || dropBoth ] + let stdoutCheckCount = length $ [ () | keepStdout || keepBoth ] ++ [ () | conflateStdout || conflateBoth ] ++ [ () | dropStdout || dropBoth ] + let stderrCheckCount = length $ [ () | keepStderr || keepBoth ] ++ [ () | conflateStderr || conflateBoth ] ++ [ () | dropStderr || dropBoth ] adjustedNumLines <- case termSizeMay of - Just (termLines, _) | maxLines -> pure $ max 1 (termLines - 3) + Just (termLines, _) | maxLines -> pure $ max 1 (termLines - 3) Just (termLines, _) | termLines < numLines + 3 -> do let actual = max 1 (termLines - 3) - errorConcurrent - $ "Warning: output is too small, only showing " - ++ show actual - ++ " lines!\n" + errorConcurrent $ "Warning: output is too small, only showing " ++ show actual ++ " lines!\n" pure actual _ -> pure numLines let compiler joinMode x = do @@ -658,8 +719,10 @@ main = B.mainFromCmdParser $ do , yieldFull <&> compiler JoinYield , summarize <&> compiler JoinSpecific . (\x -> "^(" ++ x ++ ")") , summarizeFull <&> compiler JoinSpecific - , skip <&> compiler JoinAll . (\x -> "^(" ++ x ++ ")") - , skipFull <&> compiler JoinAll + , header <&> compiler JoinHeader . (\x -> "^(" ++ x ++ ")") + , headerFull <&> compiler JoinHeader + , dropArg <&> compiler JoinAllDrop . (\x -> "^(" ++ x ++ ")") + , dropFull <&> compiler JoinAllDrop ] (lastLine, ecMay) <- displayConsoleRegions $ do initialState <- do @@ -667,33 +730,29 @@ main = B.mainFromCmdParser $ do line0 <- openConsoleRegion Linear pure State { s_config = Config - { c_label = case label of - [] -> - let full = unwords $ map quoteIfSpaces rest - in t $ if length full < 80 then full else head rest - [labelStr] -> t labelStr - _ -> error "too many labels!" - , c_lines = adjustedNumLines - , c_keepStdout = if - | stdoutCheckCount > 1 -> error - "too many keep/drop/conflate for stdout!" - | keepStdout || keepBoth -> Keep - | conflateStdout || conflateBoth -> Conflate - | dropStdout || dropBoth -> Drop - | otherwise -> Keep - , c_keepStderr = if - | stderrCheckCount > 1 -> error - "too many keep/drop/conflate for stderr!" - | keepStderr || keepBoth -> Keep - | conflateStderr || conflateBoth -> Conflate - | dropStderr || dropBoth -> Drop - | otherwise -> Keep - , c_summarize = compiled_summarize - , c_outFile = Nothing - , c_errFile = Nothing - , c_sectionChar = Nothing -- if section then Just '#' else Nothing - , c_termSize = termSizeMay - } + { c_label = case label of + [] -> let full = unwords $ map quoteIfSpaces rest in t $ if length full < 80 then full else head rest + [labelStr] -> t labelStr + _ -> error "too many labels!" + , c_lines = adjustedNumLines + , c_keepStdout = if + | stdoutCheckCount > 1 -> error "too many keep/drop/conflate for stdout!" + | keepStdout || keepBoth -> Keep + | conflateStdout || conflateBoth -> Conflate + | dropStdout || dropBoth -> Drop + | otherwise -> Keep + , c_keepStderr = if + | stderrCheckCount > 1 -> error "too many keep/drop/conflate for stderr!" + | keepStderr || keepBoth -> Keep + | conflateStderr || conflateBoth -> Conflate + | dropStderr || dropBoth -> Drop + | otherwise -> Keep + , c_summarize = compiled_summarize + , c_outFile = Nothing + , c_errFile = Nothing + , c_sectionChar = Nothing -- if section then Just '#' else Nothing + , c_termSize = termSizeMay + } , s_regions = [line0] , s_history = [] , s_lines = [] @@ -726,32 +785,21 @@ main = B.mainFromCmdParser $ do modifyMVar_ stateVar (processLine StdErr x) let tickHandler = forever $ do threadDelay 333333 - modifyMVar_ stateVar - $ execStateT - $ updateLastLine - >> updateStateLine + modifyMVar_ stateVar $ execStateT $ updateLastLine >> updateStateLine innerEnv <- do env <- System.Environment.getEnvironment pure (env ++ [("IN_HXBRIEF", "1")]) let mainBlock = - P.withCreateProcess - ((P.proc restPath restArgs) { P.std_in = P.CreatePipe - , P.std_out = P.CreatePipe - , P.std_err = P.CreatePipe - , P.env = Just innerEnv - } - ) + P.withCreateProcess ((P.proc restPath restArgs) { P.std_in = P.CreatePipe, P.std_out = P.CreatePipe, P.std_err = P.CreatePipe, P.env = Just innerEnv }) $ \(Just inp) (Just out) (Just err) hdl -> do - A.withAsync (inHandler inp) $ \inAsync -> - A.withAsync (outHandler out) $ \outAsync -> - A.withAsync (errHandler err) $ \errAsync -> - A.withAsync tickHandler $ \_tickAsync -> do - ec <- P.waitForProcess hdl - A.cancel inAsync - _a <- A.waitCatch outAsync - _b <- A.waitCatch errAsync - pure (Just ec) + A.withAsync (inHandler inp) $ \inAsync -> A.withAsync (outHandler out) $ \outAsync -> A.withAsync (errHandler err) $ \errAsync -> + A.withAsync tickHandler $ \_tickAsync -> do + ec <- P.waitForProcess hdl + A.cancel inAsync + _a <- A.waitCatch outAsync + _b <- A.waitCatch errAsync + pure (Just ec) ecMay <- restore mainBlock `catch` (\UserInterrupt -> pure Nothing) modifyMVar_ stateVar $ execStateT $ do finalLines <- gets s_lines @@ -759,30 +807,21 @@ main = B.mainFromCmdParser $ do countErr <- gets s_countErr if countOut == 0 && countErr == 1 then do - modify - $ \s -> s { s_config = (s_config s) { c_keepStderr = Keep } } - reverse finalLines - `forM_` \(kind, line, _) -> dispatchLine (kind, line) + modify $ \s -> s { s_config = (s_config s) { c_keepStderr = Keep } } + reverse finalLines `forM_` \(kind, line, _) -> dispatchLine (kind, line) else do -- we leave the lines in final state, but process them reverse finalLines `forM_` summarizeLines gets s_summary >>= \case - Nothing -> pure () - Just (kind, line, JoinedNot ) -> dispatchLine (kind, line) - Just (kind, line, JoinedYield) -> dispatchYielded (kind, line) - Just (kind, _ , JoinedAll i) -> dispatchSkipped kind i - Just (kind, _, Joined i pat prefix) -> - dispatchPat kind i pat prefix + Nothing -> pure () + Just (kind, line, JoinedNot keep) -> when keep $ dispatchYielded (kind, line) + Just (kind, line, JoinedHeader keep iOut iErr) -> when keep $ dispatchHeader kind iOut iErr line + Just (kind, _, JoinedAll keep i) -> when keep $ dispatchSkipped kind i + Just (kind, _, Joined i pat prefix) -> dispatchPat kind i pat prefix finalState <- takeMVar stateVar line <- evalStateT (bumpNowTime >> stateLine) finalState s_regions finalState `forM_` \r -> closeConsoleRegion r - let prefix = - fGrey - <> line - <> t ", " - <> setFGColorVivid Ansi.Blue - <> (c_label $ s_config finalState) - <> fGrey + let prefix = fGrey <> line <> t ", " <> setFGColorVivid Ansi.Blue <> (c_label $ s_config finalState) <> fGrey let lastLine = case ecMay of Nothing -> prefix <> t ", UserInterrupt\n" <> fReset Just ec -> prefix <> t ", ec=" <> showEC ec <> t "\n"