893 lines
39 KiB
Haskell
893 lines
39 KiB
Haskell
{-# OPTIONS_GHC -Wno-unused-imports #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
|
|
module Main
|
|
( main
|
|
)
|
|
where
|
|
|
|
|
|
import Control.Concurrent ( threadDelay )
|
|
import qualified Control.Concurrent.Async as A
|
|
import Control.Concurrent.MVar
|
|
import Control.Exception ( AsyncException(UserInterrupt)
|
|
, IOException
|
|
, bracket
|
|
, catch
|
|
, mask
|
|
, throwIO
|
|
, try
|
|
)
|
|
import Control.Monad ( forM_
|
|
, forever
|
|
, join
|
|
, replicateM
|
|
, unless
|
|
, when
|
|
, zipWithM_
|
|
)
|
|
import Control.Monad.IO.Class ( MonadIO
|
|
, liftIO
|
|
)
|
|
import Control.Monad.Trans.State.Strict
|
|
( StateT(StateT)
|
|
, evalStateT
|
|
, execStateT
|
|
, get
|
|
, gets
|
|
, modify
|
|
, put
|
|
)
|
|
import qualified Data.Char as Char
|
|
import Data.List ( isInfixOf
|
|
, isPrefixOf
|
|
, isSuffixOf
|
|
)
|
|
import Data.Maybe ( listToMaybe
|
|
, mapMaybe
|
|
)
|
|
import Data.Text ( Text )
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.IO as Text.IO
|
|
import qualified GHC.IO.Encoding
|
|
import Lens.Micro ( (<&>) )
|
|
import System.Clock ( Clock(RealtimeCoarse)
|
|
, TimeSpec
|
|
, diffTimeSpec
|
|
, getTime
|
|
, toNanoSecs
|
|
)
|
|
import qualified System.Console.ANSI as Ansi
|
|
import System.Console.Concurrent ( errorConcurrent
|
|
, flushConcurrentOutput
|
|
, outputConcurrent
|
|
, withConcurrentOutput
|
|
)
|
|
import System.Console.Regions ( ConsoleRegion
|
|
, RegionLayout(Linear)
|
|
, closeConsoleRegion
|
|
, displayConsoleRegions
|
|
, openConsoleRegion
|
|
, setConsoleRegion
|
|
)
|
|
import qualified System.Environment
|
|
import System.Exit ( exitSuccess
|
|
, exitWith
|
|
)
|
|
import System.IO ( Handle
|
|
, IOMode(WriteMode)
|
|
)
|
|
import qualified System.IO
|
|
import qualified System.Process as P
|
|
import qualified Text.PrettyPrint.HughesPJ as PP
|
|
import Text.Printf ( printf )
|
|
import Text.Read ( readMaybe )
|
|
import qualified Text.Regex.Base.RegexLike as Regex
|
|
import qualified Text.Regex.PCRE.Text as PCRE
|
|
import qualified UI.Butcher.Monadic as B
|
|
|
|
import Util
|
|
|
|
|
|
data StreamKind = StdOut | StdErr
|
|
deriving (Eq, Show)
|
|
|
|
data JoinMode
|
|
= 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
|
|
| JoinHeader1 -- join with nothing, stays, only gets replaced by next yield/header
|
|
| JoinHeader2
|
|
| JoinErrorStart
|
|
| JoinErrorStop
|
|
|
|
data JoinedInfo
|
|
= JoinedNot Bool -- yield or drop, not to be merged. bool determines whether to forward
|
|
| JoinedHeader TimeSpec Bool (Maybe Text) 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
|
|
= Drop -- dont forward
|
|
| Keep -- forward each line, apart from summaries
|
|
| Conflate -- summarize non-summarized lines as "*"
|
|
deriving (Eq, Show)
|
|
|
|
data Config = Config
|
|
{ c_label :: Text
|
|
, c_lines :: Int
|
|
, c_keepStdout :: KeepMode
|
|
, c_keepStderr :: KeepMode
|
|
, c_summarize :: [(JoinMode, Text, PCRE.Regex)]
|
|
, c_errorStop :: [PCRE.Regex]
|
|
, c_outFile :: Maybe Handle
|
|
, c_errFile :: Maybe Handle
|
|
, c_sectionChar :: Maybe Char
|
|
, c_termSize :: Maybe (Int, Int)
|
|
-- We don't need this in the config currently.
|
|
-- , c_filterEscapes :: Bool
|
|
}
|
|
|
|
data State = State
|
|
{ s_config :: Config
|
|
, s_regions :: [ConsoleRegion]
|
|
, s_history :: [(StreamKind, Text)]
|
|
, s_lines :: [(StreamKind, Text, Float)]
|
|
, s_countOut :: Int
|
|
, s_countErr :: Int
|
|
, s_globalStart :: TimeSpec
|
|
, s_lastLineTime :: TimeSpec
|
|
, s_nowTime :: TimeSpec
|
|
, s_summary :: Summary
|
|
}
|
|
|
|
data Summary
|
|
= SummaryNone
|
|
| SummaryNorm StreamKind Text JoinedInfo
|
|
| SummaryErr StreamKind Text
|
|
|
|
|
|
-- bumpLineTime :: StateT State IO ()
|
|
-- bumpLineTime = do
|
|
-- now <- liftIO $ getTime RealtimeCoarse
|
|
-- modify $ \s -> s { s_lastLineTime = s_nowTime s, s_nowTime = now }
|
|
|
|
bumpBothTimes :: StateT State IO ()
|
|
bumpBothTimes = do
|
|
now <- liftIO $ getTime RealtimeCoarse
|
|
modify $ \s -> s { s_lastLineTime = now, s_nowTime = now }
|
|
|
|
bumpNowTime :: StateT State IO ()
|
|
bumpNowTime = do
|
|
now <- liftIO $ getTime RealtimeCoarse
|
|
modify $ \s -> s { s_nowTime = now }
|
|
|
|
diffTimes :: TimeSpec -> TimeSpec -> Float
|
|
diffTimes a b =
|
|
fromIntegral (toNanoSecs (diffTimeSpec a b) `div` 1000000) / (1000 :: Float)
|
|
|
|
stateLine :: StateT State IO Text
|
|
stateLine = do
|
|
s <- get
|
|
let diffFloat1 = diffTimes (s_globalStart s) (s_nowTime s)
|
|
let diffFloat2 = diffTimes (s_lastLineTime s) (s_nowTime s)
|
|
let outStr = if False && diffFloat2 > 1.0
|
|
then t $ printf
|
|
"waiting since %0.0fs … %0.1fs total, %i/%i lines stdout/stderr"
|
|
diffFloat2
|
|
diffFloat1
|
|
(s_countOut s)
|
|
(s_countErr s)
|
|
else t $ printf "%0.3fs total, %i lines stdout %i lines stderr"
|
|
diffFloat1
|
|
(s_countOut s)
|
|
(s_countErr s)
|
|
pure $ outStr
|
|
|
|
firstJust :: (a -> Maybe b) -> [a] -> Maybe b
|
|
firstJust f = listToMaybe . mapMaybe f
|
|
|
|
dispatchLine :: (StreamKind, Text) -> StateT State IO ()
|
|
dispatchLine line@(kind, str) = do
|
|
conf <- gets s_config
|
|
liftIO $ case kind of
|
|
StdOut -> when (c_keepStdout conf /= Drop)
|
|
$ outputConcurrent (fReset <> str <> t "\n")
|
|
StdErr -> when (c_keepStderr conf /= Drop)
|
|
$ errorConcurrent (fReset <> str <> t "\n")
|
|
modify $ \s -> s { s_history = line : s_history s }
|
|
|
|
dispatchYielded :: (StreamKind, Text) -> StateT State IO ()
|
|
dispatchYielded line@(kind, str) = do
|
|
liftIO $ case kind of
|
|
StdOut -> outputConcurrent (fReset <> str <> t "\n")
|
|
StdErr -> errorConcurrent (fReset <> str <> t "\n")
|
|
modify $ \s -> s { s_history = line : s_history s }
|
|
|
|
showPattern :: Text -> Text
|
|
showPattern p = setFGColorVivid Ansi.Yellow <> p <> fReset
|
|
|
|
dispatchPat :: StreamKind -> Int -> Text -> [Text] -> StateT State IO ()
|
|
dispatchPat oldKind i pat prefix = do
|
|
let kindStr = case oldKind of
|
|
StdOut -> t "stdout"
|
|
StdErr -> t "stderr"
|
|
let betterName =
|
|
let a = Text.unwords prefix
|
|
la = Text.length a
|
|
in if
|
|
| i == 1 && la < 70
|
|
-> a
|
|
| la > Text.length pat && la < 70
|
|
-> a <> setFGColorVivid Ansi.Yellow <> t " …" <> fReset
|
|
| otherwise
|
|
-> showPattern pat
|
|
let prettyPat =
|
|
fGrey
|
|
<> t "("
|
|
<> t (show i)
|
|
<> t " lines "
|
|
<> kindStr
|
|
<> t ")"
|
|
<> fReset
|
|
<> t " "
|
|
<> betterName
|
|
<> 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
|
|
|
|
showHeader :: Float -> Text -> Maybe Text -> Int -> Int -> Text
|
|
showHeader diffTime header mLevel2 countOut countErr =
|
|
header
|
|
<> (maybe (t "") (\l2 -> t " " <> l2) mLevel2)
|
|
<> fGrey
|
|
<> t (printf " (%i/%i lines out/err, %0.1fs)" countOut countErr diffTime)
|
|
<> fReset
|
|
|
|
dispatchHeader
|
|
:: TimeSpec -> StreamKind -> Int -> Int -> Text -> StateT State IO ()
|
|
dispatchHeader startTime oldKind countOut countErr header = do
|
|
now <- gets s_nowTime
|
|
let prettyPat =
|
|
showHeader (diffTimes startTime now) header Nothing 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
|
|
StdOut -> t "stdout"
|
|
StdErr -> t "stderr"
|
|
let prettyPat :: Text =
|
|
fGrey
|
|
<> t "("
|
|
<> t (show i)
|
|
<> t " lines "
|
|
<> kindStr
|
|
<> t ") …skipped…"
|
|
<> fReset
|
|
<> 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
|
|
|
|
dispatchSummary :: Summary -> StateT State IO ()
|
|
dispatchSummary = \case
|
|
SummaryErr kind line -> dispatchYielded (kind, line)
|
|
SummaryNone -> pure ()
|
|
SummaryNorm kind line (JoinedNot keep) ->
|
|
when keep $ dispatchYielded (kind, line)
|
|
SummaryNorm kind line (JoinedHeader startTime keep _mLevel2 iOut iErr) ->
|
|
when keep $ dispatchHeader startTime kind iOut iErr line
|
|
SummaryNorm kind _ (JoinedAll keep i ) -> when keep $ dispatchSkipped kind i
|
|
SummaryNorm kind _ (Joined i pat prefix) -> dispatchPat kind i pat prefix
|
|
|
|
summarizeLines :: (StreamKind, Text, Float) -> StateT State IO ()
|
|
summarizeLines (kind, line, _linetime) = do
|
|
s <- get
|
|
let conf = s_config s
|
|
let match :: (JoinMode, Text) =
|
|
case
|
|
( firstJust
|
|
(\(mode, pat, regex) -> if Regex.matchTest regex line
|
|
then Just (mode, pat)
|
|
else Nothing
|
|
)
|
|
(c_summarize conf)
|
|
, kind
|
|
)
|
|
of
|
|
(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 "*")
|
|
let
|
|
defaultReplace = put s
|
|
{ s_summary =
|
|
(case match of
|
|
(JoinYield , _) -> SummaryNorm kind line (JoinedNot True)
|
|
(JoinAllKeep, _) -> SummaryNorm kind line (JoinedAll True 1)
|
|
(JoinAllDrop, _) -> SummaryNorm kind line (JoinedAll False 1)
|
|
(JoinSpecific, pat) ->
|
|
SummaryNorm kind line (Joined 1 pat (Text.words line))
|
|
(JoinHeader1, _) ->
|
|
SummaryNorm kind line (JoinedHeader (s_nowTime s) False Nothing 0 0)
|
|
(JoinHeader2, _) ->
|
|
SummaryNorm kind line (JoinedHeader (s_nowTime s) False Nothing 0 0)
|
|
(JoinDrop , _) -> SummaryNorm kind line (JoinedNot False)
|
|
(JoinErrorStart, _) -> SummaryErr kind line
|
|
(JoinErrorStop, _) ->
|
|
error "hxbrief internal error, unexpected JoinErrorStop"
|
|
)
|
|
}
|
|
case (s_summary s, match) of
|
|
(SummaryNone, (JoinErrorStart, _)) -> do
|
|
put s { s_summary = SummaryErr kind line }
|
|
(summary@SummaryNorm{}, (JoinErrorStart, _)) -> do
|
|
dispatchSummary summary
|
|
put s { s_summary = SummaryErr kind line }
|
|
(SummaryErr oldKind oldLine, _) -> do
|
|
dispatchYielded (oldKind, oldLine)
|
|
case
|
|
firstJust
|
|
(\regex -> if Regex.matchTest regex line then Just () else Nothing)
|
|
(c_errorStop conf)
|
|
of
|
|
Just () -> defaultReplace
|
|
Nothing -> do
|
|
put s { s_summary = SummaryErr kind line }
|
|
(SummaryNone, _ ) -> defaultReplace
|
|
-- (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
|
|
-- )
|
|
-- }
|
|
(SummaryNorm oldKind oldLine (JoinedNot keep), _joiner) -> do
|
|
when keep $ dispatchYielded (oldKind, oldLine)
|
|
defaultReplace
|
|
(SummaryNorm oldKind oldLine (JoinedHeader startTime keep mLevel2 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))
|
|
(JoinHeader1, _) ->
|
|
Just (JoinedHeader (s_nowTime s) False Nothing 0 0)
|
|
(JoinHeader2 , _) -> Nothing
|
|
(JoinDrop , _) -> Nothing
|
|
(JoinErrorStart, _) -> Nothing
|
|
(JoinErrorStop , _) -> Nothing
|
|
case replaceMay of
|
|
Just replace -> do
|
|
when keep
|
|
$ dispatchHeader startTime oldKind countOut countErr oldLine
|
|
put s { s_summary = SummaryNorm kind line replace }
|
|
Nothing -> do
|
|
let newLevel2 = case joiner of
|
|
(JoinHeader2, _) -> Just line
|
|
_ -> mLevel2
|
|
put s
|
|
{ s_summary = SummaryNorm
|
|
oldKind
|
|
oldLine
|
|
(case kind of
|
|
StdOut -> JoinedHeader startTime
|
|
keep
|
|
newLevel2
|
|
(countOut + 1)
|
|
countErr
|
|
StdErr -> JoinedHeader startTime
|
|
keep
|
|
newLevel2
|
|
countOut
|
|
(countErr + 1)
|
|
)
|
|
}
|
|
(SummaryNorm oldKind _ (JoinedAll keep i), joiner) -> case joiner of
|
|
(JoinAllKeep, _) | kind == oldKind -> do
|
|
put s { s_summary = SummaryNorm kind line (JoinedAll True (i + 1)) }
|
|
(JoinAllDrop, _) | kind == oldKind -> do
|
|
put s { s_summary = SummaryNorm kind line (JoinedAll False (i + 1)) }
|
|
_ -> do
|
|
when keep $ dispatchSkipped oldKind i
|
|
defaultReplace
|
|
(SummaryNorm 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 = SummaryNorm kind line (Joined (i + 1) pat newPrefix)
|
|
}
|
|
_ -> do
|
|
dispatchPat oldKind i oldPat oldPrefix
|
|
defaultReplace
|
|
|
|
|
|
prettyLine :: Config -> (StreamKind, Text, Float) -> Text
|
|
prettyLine conf (kind, line, linetime) =
|
|
let floatright =
|
|
if linetime > 0.2 then t $ printf " (%0.1fs)" linetime else t ""
|
|
in case kind of
|
|
StdOut ->
|
|
fWhiteDis <> t "│ " <> fReset <> ellipseFloat conf line floatright
|
|
StdErr ->
|
|
fRedDis <> t "│ " <> fReset <> ellipseFloat conf line floatright
|
|
|
|
ellipseFloat :: Config -> Text -> Text -> Text
|
|
ellipseFloat conf start floatright =
|
|
let startLength = Text.length start
|
|
floatLength = Text.length floatright
|
|
in case c_termSize conf of
|
|
Nothing -> start <> floatright
|
|
Just (_, w) ->
|
|
let remaining = w - 2 - startLength - floatLength
|
|
in if remaining >= 0
|
|
then start <> Text.replicate remaining (t " ") <> floatright
|
|
else Text.take (remaining - 1) start <> t "…" <> floatright
|
|
ellipse :: Config -> Text -> Text
|
|
ellipse conf x = ellipseFloat conf x (Text.empty)
|
|
|
|
processLine :: StreamKind -> Text -> State -> IO State
|
|
processLine newKind newLine = execStateT $ do
|
|
conf <- gets s_config
|
|
bumpBothTimes
|
|
modify $ \s -> s { s_lines = (newKind, newLine, 0) : s_lines s }
|
|
do
|
|
s0 <- get
|
|
let (keep, over) = splitAt (c_lines conf - 1) (s_lines s0)
|
|
put s0 { s_lines = keep }
|
|
over `forM_` summarizeLines
|
|
case newKind of
|
|
StdOut -> modify $ \s -> s { s_countOut = s_countOut s + 1 }
|
|
StdErr -> modify $ \s -> s { s_countErr = s_countErr s + 1 }
|
|
curLines <- gets s_lines
|
|
prettyLinesWithSummary <- do
|
|
let prettyLines =
|
|
reverse $ take (c_lines conf) curLines <&> prettyLine conf
|
|
|
|
summary <- gets s_summary
|
|
now <- gets s_nowTime
|
|
pure $ case summary of
|
|
SummaryNone -> prettyLines
|
|
SummaryNorm StdOut line (JoinedNot _) ->
|
|
(fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
|
SummaryNorm StdOut line (JoinedHeader startTime _ mLevel2 countOut countErr)
|
|
-> (fWhiteDis <> t "│ " <> fReset <> ellipse
|
|
conf
|
|
(showHeader (diffTimes startTime now)
|
|
line
|
|
mLevel2
|
|
countOut
|
|
countErr
|
|
)
|
|
)
|
|
: prettyLines
|
|
SummaryNorm StdOut line (JoinedAll _ 1) ->
|
|
(fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
|
SummaryNorm StdOut _line (JoinedAll _ i) ->
|
|
( fWhiteDis
|
|
<> t "│ "
|
|
<> fGrey
|
|
<> t "…skipped… ("
|
|
<> t (show i)
|
|
<> t " lines)"
|
|
<> fReset
|
|
)
|
|
: prettyLines
|
|
SummaryNorm StdOut line (Joined 1 _ _) ->
|
|
(fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
|
SummaryNorm StdOut _ (Joined i pat _) ->
|
|
( fWhiteDis
|
|
<> t "│ "
|
|
<> fReset
|
|
<> showPattern pat
|
|
<> fGrey
|
|
<> t " ("
|
|
<> t (show i)
|
|
<> t " lines)"
|
|
<> fReset
|
|
)
|
|
: prettyLines
|
|
SummaryErr StdOut line ->
|
|
(fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
|
SummaryNorm StdErr line (JoinedNot _) ->
|
|
(fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
|
SummaryNorm StdErr line (JoinedHeader startTime _ mLevel2 countOut countErr)
|
|
-> (fRedDis <> t "│ " <> fReset <> ellipse
|
|
conf
|
|
(showHeader (diffTimes startTime now)
|
|
line
|
|
mLevel2
|
|
countOut
|
|
countErr
|
|
)
|
|
)
|
|
: prettyLines
|
|
SummaryNorm StdErr line (JoinedAll _ 1) ->
|
|
(fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
|
SummaryNorm StdErr _line (JoinedAll _ i) ->
|
|
( fRedDis
|
|
<> t "│ "
|
|
<> fGrey
|
|
<> t "…skipped… ("
|
|
<> t (show i)
|
|
<> t " lines)"
|
|
<> fReset
|
|
)
|
|
: prettyLines
|
|
SummaryNorm StdErr line (Joined 1 _ _) ->
|
|
(fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
|
SummaryNorm StdErr _ (Joined i pat _) ->
|
|
( fRedDis
|
|
<> t "│ "
|
|
<> fReset
|
|
<> showPattern pat
|
|
<> fGrey
|
|
<> t " ("
|
|
<> t (show i)
|
|
<> t " lines)"
|
|
<> fReset
|
|
)
|
|
: prettyLines
|
|
SummaryErr StdErr line ->
|
|
(fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
|
let showCount = min (c_lines conf) (length prettyLinesWithSummary)
|
|
do -- make sure we have enough regions allocated
|
|
let need = showCount + 1
|
|
got <- gets (length . s_regions)
|
|
when (need > got) $ do
|
|
new <- liftIO $ replicateM (need - got) (openConsoleRegion Linear)
|
|
modify $ \s -> s { s_regions = s_regions s ++ new }
|
|
do
|
|
regions <- gets s_regions
|
|
liftIO $ zipWithM_
|
|
(\x region -> do
|
|
setConsoleRegion region x
|
|
)
|
|
prettyLinesWithSummary
|
|
(take showCount regions)
|
|
updateStateLine
|
|
|
|
updateLastLine :: StateT State IO ()
|
|
updateLastLine = do
|
|
bumpNowTime
|
|
modify $ \s -> s
|
|
{ s_lines = case s_lines s of
|
|
[] -> []
|
|
|
|
((k, l, _) : rest) ->
|
|
(k, l, diffTimes (s_lastLineTime s) (s_nowTime s)) : rest
|
|
}
|
|
do
|
|
s <- get
|
|
case (s_lines s, reverse $ s_regions s) of
|
|
(line : _, _ : region : _) -> do
|
|
liftIO $ setConsoleRegion region $ prettyLine (s_config s) line
|
|
_ -> pure ()
|
|
|
|
|
|
updateStateLine :: StateT State IO ()
|
|
updateStateLine = do
|
|
line <- stateLine
|
|
s <- get
|
|
liftIO $ setConsoleRegion
|
|
(last $ s_regions s)
|
|
( fGrey
|
|
<> t "╰─ … "
|
|
<> line
|
|
<> t ", "
|
|
<> setFGColorVivid Ansi.Blue
|
|
<> (c_label $ s_config s)
|
|
<> fReset
|
|
)
|
|
|
|
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-all"] mempty
|
|
dropStdout <- B.addSimpleBoolFlag "" ["drop-out"] mempty
|
|
dropStderr <- B.addSimpleBoolFlag "" ["drop-err"] mempty
|
|
dropBoth <- B.addSimpleBoolFlag "" ["drop-all"] mempty
|
|
conflateStdout <- B.addSimpleBoolFlag "" ["conflate-out"] mempty
|
|
conflateStderr <- B.addSimpleBoolFlag "" ["conflate-err"] mempty
|
|
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")
|
|
header2 <- B.addFlagStringParams "" ["header2"] "REGEX" (B.flagHelpStr "starting with this pattern: always replaces summary, then gets dropped")
|
|
header2Full <- B.addFlagStringParams "" ["header2-any"] "REGEX" (B.flagHelpStr "containing this pattern: always replaces summary, then gets dropped")
|
|
errorStart <- B.addFlagStringParams "" ["error-start"] "REGEX" mempty
|
|
errorStartFull <- B.addFlagStringParams "" ["error-start-any"] "REGEX" mempty
|
|
errorStop <- B.addFlagStringParams "" ["error-stop"] "REGEX" mempty
|
|
errorStopFull <- B.addFlagStringParams "" ["error-stop-any"] "REGEX" mempty
|
|
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")
|
|
filterEscapes <- B.addSimpleBoolFlag "" ["filter-escape-sequences"] (B.flagHelpStr "filter console escape-sequences from process output. Slower, but prevents glitches.")
|
|
-- section <- B.addSimpleBoolFlag "" ["section"] mempty
|
|
B.reorderStop
|
|
rest <- B.addParamRestOfInputRaw "COMMAND" mempty <&> \case
|
|
B.InputString ('-' : '-' : ' ' : r) -> words r
|
|
B.InputString ('-' : '-' : r) -> words r
|
|
B.InputString (r ) -> words r
|
|
B.InputArgs ("--" : r ) -> r
|
|
B.InputArgs r -> r
|
|
helpDesc <- B.peekCmdDesc
|
|
B.addCmdImpl $ do
|
|
when (null rest) $ do
|
|
print $ B.ppHelpShallow helpDesc
|
|
exitSuccess
|
|
let (restPath : restArgs) = rest
|
|
recursiveMay <- System.Environment.lookupEnv "IN_HXBRIEF"
|
|
case recursiveMay of
|
|
Just _ -> do
|
|
-- TODO: Arguably, we should do _something_ here, e.g. summarizing
|
|
-- and filtering etc.
|
|
P.callProcess restPath restArgs
|
|
exitSuccess
|
|
Nothing -> pure ()
|
|
let mainBracket = bracket
|
|
(do
|
|
System.IO.hSetEcho System.IO.stdin False
|
|
System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering
|
|
GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
|
|
case (tee, teeBoth) of
|
|
([] , []) -> pure (Nothing, Nothing)
|
|
([teeName], []) -> do
|
|
h1 <- System.IO.openFile (teeName ++ ".out.txt") WriteMode
|
|
h2 <- System.IO.openFile (teeName ++ ".err.txt") WriteMode
|
|
pure (Just h1, Just h2)
|
|
([], [teeBothName]) -> do
|
|
h <- System.IO.openFile teeBothName WriteMode
|
|
pure (Just h, Just h)
|
|
_ -> error "too many/conflicting tee arguments!"
|
|
)
|
|
(\teeHandles -> do
|
|
fst teeHandles `forM_` System.IO.hClose
|
|
snd teeHandles `forM_` System.IO.hClose
|
|
-- ^ may be closed already, this is not an error according to docs!
|
|
System.IO.hSetEcho System.IO.stdin True
|
|
)
|
|
withConcurrentOutput $ mainBracket $ \teeHandles -> mask $ \restore -> do
|
|
-- restore $ GHC.IO.Encoding.setFileSystemEncoding GHC.IO.Encoding.utf8
|
|
-- restore $ System.IO.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8
|
|
-- restore $ System.IO.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8
|
|
termSizeMay <- restore $ do
|
|
support <- Ansi.hSupportsANSI System.IO.stdin
|
|
if support
|
|
then Ansi.getTerminalSize
|
|
else 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 ]
|
|
adjustedNumLines <- case termSizeMay of
|
|
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"
|
|
pure actual
|
|
_ -> pure numLines
|
|
let compiler joinMode x = do
|
|
let tx = t x
|
|
regexE <- PCRE.compile PCRE.compBlank PCRE.execBlank tx
|
|
case regexE of
|
|
Left err -> error $ show err
|
|
Right regex -> pure (joinMode, tx, regex)
|
|
compilerStop x = do
|
|
let tx = t x
|
|
regexE <- PCRE.compile PCRE.compBlank PCRE.execBlank tx
|
|
case regexE of
|
|
Left err -> error $ show err
|
|
Right regex -> pure regex
|
|
compiled_summarize <-
|
|
sequence
|
|
$ join
|
|
$ [ yield <&> compiler JoinYield . (\x -> "^(" ++ x ++ ")")
|
|
, yieldFull <&> compiler JoinYield
|
|
, summarize <&> compiler JoinSpecific . (\x -> "^(" ++ x ++ ")")
|
|
, summarizeFull <&> compiler JoinSpecific
|
|
, header <&> compiler JoinHeader1 . (\x -> "^(" ++ x ++ ")")
|
|
, headerFull <&> compiler JoinHeader1
|
|
, header2 <&> compiler JoinHeader2 . (\x -> "^(" ++ x ++ ")")
|
|
, header2Full <&> compiler JoinHeader2
|
|
, dropArg <&> compiler JoinAllDrop . (\x -> "^(" ++ x ++ ")")
|
|
, dropFull <&> compiler JoinAllDrop
|
|
, errorStart <&> compiler JoinErrorStart . (\x -> "^(" ++ x ++ ")")
|
|
, errorStartFull <&> compiler JoinErrorStart
|
|
]
|
|
compiled_errorStop <- sequence $ join [errorStop <&> compilerStop . (\x -> "^(" ++ x ++ ")"), errorStopFull <&> compilerStop]
|
|
(lastLine, ecMay) <- displayConsoleRegions $ do
|
|
initialState <- do
|
|
startTime <- getTime RealtimeCoarse
|
|
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_errorStop = compiled_errorStop
|
|
, 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 = []
|
|
, s_countOut = 0
|
|
, s_countErr = 0
|
|
, s_globalStart = startTime
|
|
, s_lastLineTime = startTime
|
|
, s_nowTime = startTime
|
|
, s_summary = SummaryNone
|
|
}
|
|
stateVar :: MVar State <- newMVar initialState
|
|
|
|
let inHandler inp =
|
|
let go = do
|
|
x <- try getLine
|
|
case x of
|
|
Left (_ :: IOException) -> System.IO.hClose inp
|
|
Right line -> do
|
|
System.IO.hPutStrLn inp line
|
|
System.IO.hFlush inp
|
|
go
|
|
in go
|
|
let outHandler out = forever $ do
|
|
rawLine <- Text.IO.hGetLine out
|
|
let line = if filterEscapes then filterEscapeFunc rawLine else Text.filter (/= '\r') rawLine
|
|
fst teeHandles `forM_` \h -> Text.IO.hPutStrLn h line
|
|
modifyMVar_ stateVar (processLine StdOut line)
|
|
let errHandler err = forever $ do
|
|
rawLine <- Text.IO.hGetLine err
|
|
let line = if filterEscapes then filterEscapeFunc rawLine else Text.filter (/= '\r') rawLine
|
|
snd teeHandles `forM_` \h -> Text.IO.hPutStrLn h line
|
|
modifyMVar_ stateVar (processLine StdErr line)
|
|
let tickHandler = forever $ do
|
|
threadDelay 333333
|
|
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 })
|
|
$ \(Just inp) (Just out) (Just err) hdl -> do
|
|
System.IO.hSetBuffering out System.IO.LineBuffering
|
|
System.IO.hSetBuffering err System.IO.LineBuffering
|
|
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
|
|
countOut <- gets s_countOut
|
|
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)
|
|
else do
|
|
-- we leave the lines in final state, but process them
|
|
reverse finalLines `forM_` summarizeLines
|
|
gets s_summary >>= dispatchSummary
|
|
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 lastLine = case ecMay of
|
|
Nothing -> prefix <> t ", UserInterrupt\n" <> fReset
|
|
Just ec -> prefix <> t ", ec=" <> showEC ec <> t "\n"
|
|
pure (lastLine, ecMay)
|
|
|
|
flushConcurrentOutput
|
|
unless omitSummary $ errorConcurrent lastLine
|
|
case ecMay of
|
|
Nothing -> throwIO UserInterrupt -- essentially re-throw
|
|
Just ec -> exitWith ec
|
|
|