hexagoxel
/
hxtools
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Support headers

master
Lennart Spitzner 2022-12-12 13:03:09 +01:00
parent 33019050c5
commit 095eab90dc
1 changed files with 264 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

489
src-hxbrief/Main.hs
View File

@ -93,14 +93,17 @@ data StreamKind = StdOut | StdErr
deriving (Eq, Show) deriving (Eq, Show)
data JoinMode data JoinMode
= JoinYield -- i.e. don't join: We want to yield that exact line = JoinYield -- don't join: We want to yield that exact line
| JoinAll -- join with any other JoinAll-tagged lines/patterns | 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 | JoinSpecific -- join with this pattern only
| JoinHeader -- join with nothing, stays, only gets replaced by next yield/header
data JoinedInfo data JoinedInfo
= JoinedNot -- Line did not match any pattern = JoinedNot Bool -- yield or drop, not to be merged. bool determines whether to forward
| JoinedYield -- Line matched a yield pattern, must be forwarded as-is | JoinedHeader Bool Int Int -- header, not to be merged. bool determines whether to forward. Int is count stdout/stderr
| JoinedAll Int | JoinedAll Bool Int -- bool determines whether to forward
| Joined Int Text [Text] -- pattern, prefix | Joined Int Text [Text] -- pattern, prefix
data KeepMode data KeepMode
@ -226,6 +229,25 @@ dispatchPat oldKind i pat prefix = do
StdOut -> when (c_keepStdout conf /= Drop) $ outputConcurrent prettyPat StdOut -> when (c_keepStdout conf /= Drop) $ outputConcurrent prettyPat
StdErr -> when (c_keepStderr conf /= Drop) $ errorConcurrent 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 :: StreamKind -> Int -> StateT State IO ()
dispatchSkipped oldKind i = do dispatchSkipped oldKind i = do
let kindStr = case oldKind of let kindStr = case oldKind of
@ -250,102 +272,140 @@ summarizeLines :: (StreamKind, Text, Float) -> StateT State IO ()
summarizeLines (kind, line, _linetime) = do summarizeLines (kind, line, _linetime) = do
s <- get s <- get
let conf = s_config s let conf = s_config s
let match :: Maybe (JoinMode, Text) = let match :: (JoinMode, Text) =
case case
firstJust ( firstJust
(\(mode, pat, regex) -> if Regex.matchTest regex line (\(mode, pat, regex) -> if Regex.matchTest regex line
then Just (mode, pat) then Just (mode, pat)
else Nothing else Nothing
) )
(c_summarize conf) (c_summarize conf)
, kind
)
of of
j@Just{} -> j (Just j , _ ) -> j
Nothing | kind == StdOut && c_keepStdout conf == Conflate -> (Nothing, StdOut) -> case c_keepStdout conf of
Just (JoinAll, t "*") Conflate -> (JoinAllKeep, t "*")
Nothing | kind == StdErr && c_keepStderr conf == Conflate -> Keep -> (JoinYield, t "*")
Just (JoinAll, t "*") Drop -> (JoinDrop, t "*")
Nothing -> Nothing (Nothing, StdErr) -> case c_keepStderr conf of
Conflate -> (JoinAllKeep, t "*")
Keep -> (JoinYield, t "*")
Drop -> (JoinDrop, t "*")
case (s_summary s, match) of case (s_summary s, match) of
(Nothing, _) -> put s (Nothing, _) -> put s
{ s_summary = Just { s_summary = Just
( kind ( kind
, line , line
, case match of , case match of
Nothing -> JoinedNot (JoinYield , _ ) -> JoinedNot True
Just (JoinYield , _ ) -> JoinedYield (JoinAllKeep , _ ) -> JoinedAll True 1
Just (JoinAll , _ ) -> JoinedAll 1 (JoinAllDrop , _ ) -> JoinedAll False 1
Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) (JoinSpecific, pat) -> Joined 1 pat (Text.words line)
) (JoinHeader , _ ) -> JoinedHeader False 0 0
(JoinDrop , _ ) -> JoinedNot False
)
} }
(Just (oldKind, oldLine, JoinedNot), _) -> do -- (Just (oldKind, oldLine, JoinedNot), _) -> do
dispatchLine (oldKind, oldLine) -- 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 put s
{ s_summary = Just { s_summary = case joiner of
( kind (JoinYield , _pat) -> Just (kind, line, JoinedNot True)
, line (JoinAllKeep, _ ) -> Just (kind, line, JoinedAll True 1)
, case match of (JoinAllDrop, _ ) -> Just (kind, line, JoinedAll False 1)
Nothing -> JoinedNot (JoinSpecific, pat) ->
Just (JoinYield , _ ) -> JoinedYield Just (kind, line, Joined 1 pat (Text.words line))
Just (JoinAll , _ ) -> JoinedAll 1 (JoinHeader, _) -> Just (kind, line, JoinedHeader False 0 0)
Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) (JoinDrop , _) -> Just (kind, line, JoinedNot False)
)
} }
(Just (oldKind, oldLine, JoinedYield), Nothing) -> do (Just (oldKind, oldLine, JoinedHeader keep countOut countErr), joiner) ->
dispatchYielded (oldKind, oldLine) do
put s { s_summary = Just (kind, line, JoinedNot) } let replaceMay = case joiner of
(Just (oldKind, oldLine, JoinedYield), _) -> do (JoinYield , _pat) -> Just (JoinedNot True)
dispatchYielded (oldKind, oldLine) (JoinAllKeep , _ ) -> Just (JoinedAll True 1)
put s (JoinAllDrop , _ ) -> Nothing
{ s_summary = Just (JoinSpecific, pat ) -> Just (Joined 1 pat (Text.words line))
( kind (JoinHeader , _ ) -> Just (JoinedHeader False 0 0)
, line (JoinDrop , _ ) -> Nothing
, case match of case replaceMay of
Nothing -> JoinedNot Just replace -> do
Just (JoinAll , _ ) -> JoinedAll 1 when keep $ dispatchHeader oldKind countOut countErr oldLine
Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) put s { s_summary = Just (kind, line, replace) }
Just (JoinYield , _ ) -> JoinedYield Nothing -> do
) put s
} { s_summary = Just
(Just (oldKind, _, JoinedAll i), Nothing) -> do ( oldKind
dispatchSkipped oldKind i , oldLine
put s { s_summary = Just (kind, line, JoinedNot) } , case kind of
(Just (oldKind, _, Joined i oldPat oldPrefix), Nothing) -> do StdOut ->
dispatchPat oldKind i oldPat oldPrefix JoinedHeader keep (countOut + 1) countErr
put s { s_summary = Just (kind, line, JoinedNot) } StdErr ->
(Just (oldKind, _, JoinedAll i), Just joiner) -> case joiner of JoinedHeader keep countOut (countErr + 1)
)
}
(Just (oldKind, _, JoinedAll keep i), joiner) -> case joiner of
(JoinYield, _pat) -> do (JoinYield, _pat) -> do
dispatchSkipped oldKind i when keep $ dispatchSkipped oldKind i
put s { s_summary = Just (kind, line, JoinedYield) } put s { s_summary = Just (kind, line, JoinedNot True) }
(JoinAll, _) (JoinAllKeep, _)
| kind == oldKind -> do | 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 | otherwise -> do
dispatchSkipped oldKind i when keep $ dispatchSkipped oldKind i
put s { s_summary = Just (kind, line, JoinedAll 1) } 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 (JoinSpecific, pat) -> do
dispatchSkipped oldKind i dispatchSkipped oldKind i
put s { s_summary = Just (kind, line, Joined 1 pat (Text.words line)) } put s { s_summary = Just (kind, line, Joined 1 pat (Text.words line)) }
(Just (oldKind, _, Joined i oldPat oldPrefix), Just joiner) -> (JoinHeader, _) -> do
case joiner of dispatchSkipped oldKind i
(JoinSpecific, pat) | oldPat == pat && kind == oldKind -> do put s { s_summary = Just (kind, line, JoinedHeader False 0 0) }
let newPrefix = (JoinDrop, _) -> do
let go [] = [] dispatchSkipped oldKind i
go ((a, b) : rest) | a == b = a : go rest put s { s_summary = Just (kind, line, JoinedNot False) }
| otherwise = [] (Just (oldKind, _, Joined i oldPat oldPrefix), joiner) -> case joiner of
in go $ zip oldPrefix (Text.words line) (JoinSpecific, pat) | oldPat == pat && kind == oldKind -> do
put s { s_summary = Just (kind, line, Joined (i + 1) pat newPrefix) } let newPrefix =
_ -> do let go [] = []
dispatchPat oldKind i oldPat oldPrefix go ((a, b) : rest) | a == b = a : go rest
put s | otherwise = []
{ s_summary = Just in go $ zip oldPrefix (Text.words line)
( kind put s { s_summary = Just (kind, line, Joined (i + 1) pat newPrefix) }
, line _ -> do
, case joiner of dispatchPat oldKind i oldPat oldPrefix
(JoinYield , _ ) -> JoinedYield put s
(JoinAll , _ ) -> JoinedAll 1 { s_summary = Just
(JoinSpecific, pat) -> Joined 1 pat (Text.words line) ( 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 prettyLine :: Config -> (StreamKind, Text, Float) -> Text
@ -393,11 +453,17 @@ processLine newKind newLine = execStateT $ do
summary <- gets s_summary summary <- gets s_summary
pure $ case summary of pure $ case summary of
Nothing -> prettyLines Nothing -> prettyLines
Just (StdOut, line, JoinedNot) -> Just (StdOut, line, JoinedNot _) ->
(fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines (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 (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just (StdOut, _line, JoinedAll i) -> Just (StdOut, _line, JoinedAll _ i) ->
( fWhiteDis ( fWhiteDis
<> t "│ " <> t "│ "
<> fGrey <> fGrey
@ -421,15 +487,17 @@ processLine newKind newLine = execStateT $ do
<> fReset <> fReset
) )
: prettyLines : prettyLines
Just (StdOut, line, JoinedYield) -> Just (StdErr, line, JoinedNot _) ->
(fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just (StdErr, line, JoinedNot) ->
(fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines (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 (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just (StdErr, line, JoinedAll 1) -> Just (StdErr, _line, JoinedAll _ i) ->
(fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just (StdErr, _line, JoinedAll i) ->
( fRedDis ( fRedDis
<> t "│ " <> t "│ "
<> fGrey <> fGrey
@ -506,69 +574,73 @@ updateStateLine = do
quoteIfSpaces :: String -> String quoteIfSpaces :: String -> String
quoteIfSpaces s = if any Char.isSpace s then "\"" ++ s ++ "\"" else s quoteIfSpaces s = if any Char.isSpace s then "\"" ++ s ++ "\"" else s
-- brittany-next-binding --columns 180
main :: IO () main :: IO ()
main = B.mainFromCmdParser $ do main = B.mainFromCmdParser $ do
B.reorderStart 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) numLines :: Int <- B.addFlagReadParam "n" ["lines"] "LINES" (B.flagDefault 5)
maxLines <- B.addSimpleBoolFlag "" ["max-lines"] mempty maxLines <- B.addSimpleBoolFlag "" ["max-lines"] mempty
keepStdout <- B.addSimpleBoolFlag "" ["keep-out"] mempty keepStdout <- B.addSimpleBoolFlag "" ["keep-out"] mempty
keepStderr <- B.addSimpleBoolFlag "" ["keep-err"] mempty keepStderr <- B.addSimpleBoolFlag "" ["keep-err"] mempty
keepBoth <- B.addSimpleBoolFlag "" ["keep"] mempty keepBoth <- B.addSimpleBoolFlag "" ["keep-all"] mempty
dropStdout <- B.addSimpleBoolFlag "" ["drop-out"] mempty dropStdout <- B.addSimpleBoolFlag "" ["drop-out"] mempty
dropStderr <- B.addSimpleBoolFlag "" ["drop-err"] mempty dropStderr <- B.addSimpleBoolFlag "" ["drop-err"] mempty
dropBoth <- B.addSimpleBoolFlag "" ["drop"] mempty dropBoth <- B.addSimpleBoolFlag "" ["drop-all"] mempty
conflateStdout <- B.addSimpleBoolFlag "" ["conflate-out"] mempty conflateStdout <- B.addSimpleBoolFlag "" ["conflate-out"] mempty
conflateStderr <- B.addSimpleBoolFlag "" ["conflate-err"] mempty conflateStderr <- B.addSimpleBoolFlag "" ["conflate-err"] mempty
conflateBoth <- B.addSimpleBoolFlag "" ["conflate"] mempty conflateBoth <- B.addSimpleBoolFlag "" ["conflate-all"] mempty
summarize <- B.addFlagStringParams summarize <- B.addFlagStringParams "s" ["summarize"] "REGEX" (B.flagHelpStr "bundle lines starting with this pattern into one line")
"s" summarizeFull <- B.addFlagStringParams "" ["summarize-any"] "REGEX" (B.flagHelpStr "bundle lines containing this pattern into one line")
["summarize"] dropArg <- B.addFlagStringParams "x" ["drop"] "REGEX" (B.flagHelpStr "drop lines starting with this pattern, similar to `grep -v`")
"REGEX" dropFull <- B.addFlagStringParams "" ["drop-any"] "REGEX" (B.flagHelpStr "drop lines containing this pattern, similar to `grep -v`")
(B.flagHelpStr "bundle lines starting with this pattern into one line") label <- B.addFlagStringParams "" ["label"] "STRING" mempty
summarizeFull <- B.addFlagStringParams 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")
["summarize-any"] header <- B.addFlagStringParams "h" ["header"] "REGEX" (B.flagHelpStr "starting with this pattern: always replaces summary, then gets dropped")
"REGEX" headerFull <- B.addFlagStringParams "" ["header-any"] "REGEX" (B.flagHelpStr "containing this pattern: always replaces summary, then gets dropped")
(B.flagHelpStr "bundle lines containing this pattern into one line") omitSummary <- B.addSimpleBoolFlag "" ["omit-summary"] mempty
skip <- B.addFlagStringParams tee <- B.addFlagStringParams "" ["tee"] "BASENAMEBASEPATH" (B.flagHelp $ PP.text "Write copy of stdout/stderr to BASEPATH.{out/err}.txt")
"x" teeBoth <- B.addFlagStringParams "" ["tee-both"] "FILENAMEFILEPATH" (B.flagHelp $ PP.text "Write copy of stdout and stderr to FILEPATH")
["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")
-- section <- B.addSimpleBoolFlag "" ["section"] mempty -- section <- B.addSimpleBoolFlag "" ["section"] mempty
B.reorderStop B.reorderStop
rest <- B.addParamRestOfInputRaw "COMMAND" mempty <&> \case rest <- B.addParamRestOfInputRaw "COMMAND" mempty <&> \case
@ -625,24 +697,13 @@ main = B.mainFromCmdParser $ do
envLines <- System.Environment.lookupEnv "LINES" envLines <- System.Environment.lookupEnv "LINES"
envCols <- System.Environment.lookupEnv "COLUMNS" envCols <- System.Environment.lookupEnv "COLUMNS"
pure $ (,) <$> (envLines >>= readMaybe) <*> (envCols >>= readMaybe) pure $ (,) <$> (envLines >>= readMaybe) <*> (envCols >>= readMaybe)
let stdoutCheckCount = let stdoutCheckCount = length $ [ () | keepStdout || keepBoth ] ++ [ () | conflateStdout || conflateBoth ] ++ [ () | dropStdout || dropBoth ]
length let stderrCheckCount = length $ [ () | keepStderr || keepBoth ] ++ [ () | conflateStderr || conflateBoth ] ++ [ () | dropStderr || dropBoth ]
$ [ () | keepStdout || keepBoth ]
++ [ () | conflateStdout || conflateBoth ]
++ [ () | dropStdout || dropBoth ]
let stderrCheckCount =
length
$ [ () | keepStderr || keepBoth ]
++ [ () | conflateStderr || conflateBoth ]
++ [ () | dropStderr || dropBoth ]
adjustedNumLines <- case termSizeMay of 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 Just (termLines, _) | termLines < numLines + 3 -> do
let actual = max 1 (termLines - 3) let actual = max 1 (termLines - 3)
errorConcurrent errorConcurrent $ "Warning: output is too small, only showing " ++ show actual ++ " lines!\n"
$ "Warning: output is too small, only showing "
++ show actual
++ " lines!\n"
pure actual pure actual
_ -> pure numLines _ -> pure numLines
let compiler joinMode x = do let compiler joinMode x = do
@ -658,8 +719,10 @@ main = B.mainFromCmdParser $ do
, yieldFull <&> compiler JoinYield , yieldFull <&> compiler JoinYield
, summarize <&> compiler JoinSpecific . (\x -> "^(" ++ x ++ ")") , summarize <&> compiler JoinSpecific . (\x -> "^(" ++ x ++ ")")
, summarizeFull <&> compiler JoinSpecific , summarizeFull <&> compiler JoinSpecific
, skip <&> compiler JoinAll . (\x -> "^(" ++ x ++ ")") , header <&> compiler JoinHeader . (\x -> "^(" ++ x ++ ")")
, skipFull <&> compiler JoinAll , headerFull <&> compiler JoinHeader
, dropArg <&> compiler JoinAllDrop . (\x -> "^(" ++ x ++ ")")
, dropFull <&> compiler JoinAllDrop
] ]
(lastLine, ecMay) <- displayConsoleRegions $ do (lastLine, ecMay) <- displayConsoleRegions $ do
initialState <- do initialState <- do
@ -667,33 +730,29 @@ main = B.mainFromCmdParser $ do
line0 <- openConsoleRegion Linear line0 <- openConsoleRegion Linear
pure State pure State
{ s_config = Config { s_config = Config
{ c_label = case label of { c_label = case label of
[] -> [] -> let full = unwords $ map quoteIfSpaces rest in t $ if length full < 80 then full else head rest
let full = unwords $ map quoteIfSpaces rest [labelStr] -> t labelStr
in t $ if length full < 80 then full else head rest _ -> error "too many labels!"
[labelStr] -> t labelStr , c_lines = adjustedNumLines
_ -> error "too many labels!" , c_keepStdout = if
, c_lines = adjustedNumLines | stdoutCheckCount > 1 -> error "too many keep/drop/conflate for stdout!"
, c_keepStdout = if | keepStdout || keepBoth -> Keep
| stdoutCheckCount > 1 -> error | conflateStdout || conflateBoth -> Conflate
"too many keep/drop/conflate for stdout!" | dropStdout || dropBoth -> Drop
| keepStdout || keepBoth -> Keep | otherwise -> Keep
| conflateStdout || conflateBoth -> Conflate , c_keepStderr = if
| dropStdout || dropBoth -> Drop | stderrCheckCount > 1 -> error "too many keep/drop/conflate for stderr!"
| otherwise -> Keep | keepStderr || keepBoth -> Keep
, c_keepStderr = if | conflateStderr || conflateBoth -> Conflate
| stderrCheckCount > 1 -> error | dropStderr || dropBoth -> Drop
"too many keep/drop/conflate for stderr!" | otherwise -> Keep
| keepStderr || keepBoth -> Keep , c_summarize = compiled_summarize
| conflateStderr || conflateBoth -> Conflate , c_outFile = Nothing
| dropStderr || dropBoth -> Drop , c_errFile = Nothing
| otherwise -> Keep , c_sectionChar = Nothing -- if section then Just '#' else Nothing
, c_summarize = compiled_summarize , c_termSize = termSizeMay
, c_outFile = Nothing }
, c_errFile = Nothing
, c_sectionChar = Nothing -- if section then Just '#' else Nothing
, c_termSize = termSizeMay
}
, s_regions = [line0] , s_regions = [line0]
, s_history = [] , s_history = []
, s_lines = [] , s_lines = []
@ -726,32 +785,21 @@ main = B.mainFromCmdParser $ do
modifyMVar_ stateVar (processLine StdErr x) modifyMVar_ stateVar (processLine StdErr x)
let tickHandler = forever $ do let tickHandler = forever $ do
threadDelay 333333 threadDelay 333333
modifyMVar_ stateVar modifyMVar_ stateVar $ execStateT $ updateLastLine >> updateStateLine
$ execStateT
$ updateLastLine
>> updateStateLine
innerEnv <- do innerEnv <- do
env <- System.Environment.getEnvironment env <- System.Environment.getEnvironment
pure (env ++ [("IN_HXBRIEF", "1")]) pure (env ++ [("IN_HXBRIEF", "1")])
let mainBlock = let mainBlock =
P.withCreateProcess 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.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 $ \(Just inp) (Just out) (Just err) hdl -> do
A.withAsync (inHandler inp) $ \inAsync -> A.withAsync (inHandler inp) $ \inAsync -> A.withAsync (outHandler out) $ \outAsync -> A.withAsync (errHandler err) $ \errAsync ->
A.withAsync (outHandler out) $ \outAsync -> A.withAsync tickHandler $ \_tickAsync -> do
A.withAsync (errHandler err) $ \errAsync -> ec <- P.waitForProcess hdl
A.withAsync tickHandler $ \_tickAsync -> do A.cancel inAsync
ec <- P.waitForProcess hdl _a <- A.waitCatch outAsync
A.cancel inAsync _b <- A.waitCatch errAsync
_a <- A.waitCatch outAsync pure (Just ec)
_b <- A.waitCatch errAsync
pure (Just ec)
ecMay <- restore mainBlock `catch` (\UserInterrupt -> pure Nothing) ecMay <- restore mainBlock `catch` (\UserInterrupt -> pure Nothing)
modifyMVar_ stateVar $ execStateT $ do modifyMVar_ stateVar $ execStateT $ do
finalLines <- gets s_lines finalLines <- gets s_lines
@ -759,30 +807,21 @@ main = B.mainFromCmdParser $ do
countErr <- gets s_countErr countErr <- gets s_countErr
if countOut == 0 && countErr == 1 if countOut == 0 && countErr == 1
then do then do
modify modify $ \s -> s { s_config = (s_config s) { c_keepStderr = Keep } }
$ \s -> s { s_config = (s_config s) { c_keepStderr = Keep } } reverse finalLines `forM_` \(kind, line, _) -> dispatchLine (kind, line)
reverse finalLines
`forM_` \(kind, line, _) -> dispatchLine (kind, line)
else do else do
-- we leave the lines in final state, but process them -- we leave the lines in final state, but process them
reverse finalLines `forM_` summarizeLines reverse finalLines `forM_` summarizeLines
gets s_summary >>= \case gets s_summary >>= \case
Nothing -> pure () Nothing -> pure ()
Just (kind, line, JoinedNot ) -> dispatchLine (kind, line) Just (kind, line, JoinedNot keep) -> when keep $ dispatchYielded (kind, line)
Just (kind, line, JoinedYield) -> dispatchYielded (kind, line) Just (kind, line, JoinedHeader keep iOut iErr) -> when keep $ dispatchHeader kind iOut iErr line
Just (kind, _ , JoinedAll i) -> dispatchSkipped kind i Just (kind, _, JoinedAll keep i) -> when keep $ dispatchSkipped kind i
Just (kind, _, Joined i pat prefix) -> Just (kind, _, Joined i pat prefix) -> dispatchPat kind i pat prefix
dispatchPat kind i pat prefix
finalState <- takeMVar stateVar finalState <- takeMVar stateVar
line <- evalStateT (bumpNowTime >> stateLine) finalState line <- evalStateT (bumpNowTime >> stateLine) finalState
s_regions finalState `forM_` \r -> closeConsoleRegion r s_regions finalState `forM_` \r -> closeConsoleRegion r
let prefix = let prefix = fGrey <> line <> t ", " <> setFGColorVivid Ansi.Blue <> (c_label $ s_config finalState) <> fGrey
fGrey
<> line
<> t ", "
<> setFGColorVivid Ansi.Blue
<> (c_label $ s_config finalState)
<> fGrey
let lastLine = case ecMay of let lastLine = case ecMay of
Nothing -> prefix <> t ", UserInterrupt\n" <> fReset Nothing -> prefix <> t ", UserInterrupt\n" <> fReset
Just ec -> prefix <> t ", ec=" <> showEC ec <> t "\n" Just ec -> prefix <> t ", ec=" <> showEC ec <> t "\n"