705 lines
28 KiB
Haskell
705 lines
28 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
|
|
, 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 UI.Butcher.Monadic as B
|
|
|
|
import Util
|
|
|
|
|
|
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
|
|
| JoinSpecific -- join with this pattern only
|
|
|
|
data JoinedInfo
|
|
= JoinedNot -- Line did not match any pattern
|
|
| JoinedYield -- Line matched a yield pattern, must be forwarded as-is
|
|
| JoinedAll Int
|
|
| 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)]
|
|
, c_outFile :: Maybe Handle
|
|
, c_errFile :: Maybe Handle
|
|
, c_sectionChar :: Maybe Char
|
|
, c_termSize :: Maybe (Int, Int)
|
|
}
|
|
|
|
data State = State
|
|
{ s_config :: Config
|
|
, s_regions :: [ConsoleRegion]
|
|
, s_history :: [(StreamKind, Text)]
|
|
, s_lines :: [(StreamKind, Text)]
|
|
, s_countOut :: Int
|
|
, s_countErr :: Int
|
|
, s_globalStart :: TimeSpec
|
|
, s_lastLineTime :: TimeSpec
|
|
, s_summary :: Maybe ((StreamKind, Text), JoinedInfo)
|
|
}
|
|
|
|
|
|
getTimeDiff :: Bool -> StateT State IO (Float, Float)
|
|
getTimeDiff updateCur = do
|
|
now <- liftIO $ getTime RealtimeCoarse
|
|
when updateCur $ modify $ \s -> s { s_lastLineTime = now }
|
|
s <- get
|
|
let diffNanos1 = toNanoSecs $ diffTimeSpec (s_globalStart s) now
|
|
let diffNanos2 = toNanoSecs $ diffTimeSpec (s_lastLineTime s) now
|
|
pure
|
|
( fromIntegral (diffNanos1 `div` 1000000) / (1000 :: Float)
|
|
, fromIntegral (diffNanos2 `div` 1000000) / (1000 :: Float)
|
|
)
|
|
|
|
|
|
stateLine :: Bool -> Bool -> StateT State IO Text
|
|
stateLine updateCur showCur = do
|
|
(diffFloat1, diffFloat2) <- getTimeDiff updateCur
|
|
s <- get
|
|
let outStr = if showCur && 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
|
|
|
|
matchPattern :: Text -> Text -> Bool
|
|
matchPattern pat s = case Text.split (== '*') pat of
|
|
[] -> False
|
|
[exact] -> exact == s
|
|
[t1, t2] | Text.null t1 -> t2 `Text.isSuffixOf` s -- *foo
|
|
[t1, t2] | Text.null t2 -> t1 `Text.isPrefixOf` s -- foo*
|
|
[t1, t2] -> t1 `Text.isPrefixOf` s && t2 `Text.isSuffixOf` s -- foo*bar
|
|
[t1, t2, t3] | Text.null t1 && Text.null t3 -> t2 `Text.isInfixOf` s -- *foo*
|
|
_ -> undefined
|
|
|
|
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 = Text.concatMap
|
|
(\case
|
|
'*' -> setFGColorVivid Ansi.Yellow <> t "…" <> fReset
|
|
x -> Text.singleton x
|
|
)
|
|
|
|
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
|
|
|
|
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
|
|
|
|
|
|
summarizeLines :: (StreamKind, Text) -> StateT State IO ()
|
|
summarizeLines cur@(kind, line) = do
|
|
s <- get
|
|
let conf = s_config s
|
|
let match = firstJust
|
|
(\joiner@(_, pat) ->
|
|
if matchPattern pat line then Just joiner else Nothing
|
|
)
|
|
(c_summarize conf ++ case kind of
|
|
StdOut -> [ (JoinAll, t "*") | c_keepStdout conf == Conflate ]
|
|
StdErr -> [ (JoinAll, t "*") | c_keepStderr conf == Conflate ]
|
|
)
|
|
case (s_summary s, match) of
|
|
(Nothing, _) -> put s
|
|
{ s_summary = Just
|
|
( cur
|
|
, case match of
|
|
Nothing -> JoinedNot
|
|
Just (JoinYield , _ ) -> JoinedYield
|
|
Just (JoinAll , _ ) -> JoinedAll 1
|
|
Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line)
|
|
)
|
|
}
|
|
(Just (oldLine, JoinedNot), _) -> do
|
|
dispatchLine oldLine
|
|
put s
|
|
{ s_summary = Just
|
|
( cur
|
|
, case match of
|
|
Nothing -> JoinedNot
|
|
Just (JoinYield , _ ) -> JoinedYield
|
|
Just (JoinAll , _ ) -> JoinedAll 1
|
|
Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line)
|
|
)
|
|
}
|
|
(Just (oldLine, JoinedYield), Nothing) -> do
|
|
dispatchYielded oldLine
|
|
put s { s_summary = Just (cur, JoinedNot) }
|
|
(Just (oldLine, JoinedYield), _) -> do
|
|
dispatchYielded oldLine
|
|
put s
|
|
{ s_summary = Just
|
|
( cur
|
|
, 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 (cur, JoinedNot) }
|
|
(Just ((oldKind, _), Joined i oldPat oldPrefix), Nothing) -> do
|
|
dispatchPat oldKind i oldPat oldPrefix
|
|
put s { s_summary = Just (cur, JoinedNot) }
|
|
(Just ((oldKind, _), JoinedAll i), Just joiner) -> case joiner of
|
|
(JoinYield, _pat) -> do
|
|
dispatchSkipped oldKind i
|
|
put s { s_summary = Just (cur, JoinedYield) }
|
|
(JoinAll, _)
|
|
| kind == oldKind -> do
|
|
put s { s_summary = Just (cur, JoinedAll (i + 1)) }
|
|
| otherwise -> do
|
|
dispatchSkipped oldKind i
|
|
put s { s_summary = Just (cur, JoinedAll 1) }
|
|
(JoinSpecific, pat) -> do
|
|
dispatchSkipped oldKind i
|
|
put s { s_summary = Just (cur, 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 (cur, Joined (i + 1) pat newPrefix) }
|
|
_ -> do
|
|
dispatchPat oldKind i oldPat oldPrefix
|
|
put s
|
|
{ s_summary = Just
|
|
( cur
|
|
, case joiner of
|
|
(JoinYield , _ ) -> JoinedYield
|
|
(JoinAll , _ ) -> JoinedAll 1
|
|
(JoinSpecific, pat) -> Joined 1 pat (Text.words line)
|
|
)
|
|
}
|
|
|
|
|
|
processLine :: (StreamKind, Text) -> State -> IO State
|
|
processLine newPair@(kind, _) = execStateT $ do
|
|
conf <- gets s_config
|
|
modify $ \s -> s { s_lines = newPair : 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 kind 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 ellipse :: Text -> Text
|
|
ellipse input =
|
|
let inputLength = Text.length input
|
|
in case c_termSize conf of
|
|
Nothing -> input
|
|
Just (_, w) -> if inputLength <= w - 2
|
|
then input
|
|
else Text.take (w - 3) input <> t "…"
|
|
let prettyLines = reverse $ take (c_lines conf) curLines <&> \case
|
|
(StdOut, line) -> fWhiteDis <> t "│ " <> fReset <> ellipse line
|
|
(StdErr, line) -> fRedDis <> t "│ " <> fReset <> ellipse line
|
|
summary <- gets s_summary
|
|
pure $ case summary of
|
|
Nothing -> prettyLines
|
|
Just ((StdOut, line), JoinedNot) ->
|
|
(fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
|
|
Just ((StdOut, line), JoinedAll 1) ->
|
|
(fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
|
|
Just ((StdOut, _line), JoinedAll i) ->
|
|
( fWhiteDis
|
|
<> t "│ "
|
|
<> fGrey
|
|
<> t "…skipped… ("
|
|
<> t (show i)
|
|
<> t " lines)"
|
|
<> fReset
|
|
)
|
|
: prettyLines
|
|
Just ((StdOut, line), Joined 1 _ _) ->
|
|
(fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
|
|
Just ((StdOut, _), Joined i pat _) ->
|
|
( fWhiteDis
|
|
<> t "│ "
|
|
<> fReset
|
|
<> showPattern pat
|
|
<> fGrey
|
|
<> t " ("
|
|
<> t (show i)
|
|
<> t " lines)"
|
|
<> fReset
|
|
)
|
|
: prettyLines
|
|
Just ((StdOut, line), JoinedYield) ->
|
|
(fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
|
|
Just ((StdErr, line), JoinedNot) ->
|
|
(fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
|
|
Just ((StdErr, line), JoinedYield) ->
|
|
(fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
|
|
Just ((StdErr, line), JoinedAll 1) ->
|
|
(fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
|
|
Just ((StdErr, _line), JoinedAll i) ->
|
|
( fRedDis
|
|
<> t "│ "
|
|
<> fGrey
|
|
<> t "…skipped… ("
|
|
<> t (show i)
|
|
<> t " lines)"
|
|
<> fReset
|
|
)
|
|
: prettyLines
|
|
Just ((StdErr, line), Joined 1 _ _) ->
|
|
(fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
|
|
Just ((StdErr, _), Joined i pat _) ->
|
|
( fRedDis
|
|
<> t "│ "
|
|
<> fReset
|
|
<> showPattern pat
|
|
<> fGrey
|
|
<> t " ("
|
|
<> t (show i)
|
|
<> t " lines)"
|
|
<> fReset
|
|
)
|
|
: 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 True
|
|
|
|
updateStateLine :: Bool -> StateT State IO ()
|
|
updateStateLine updateCur = do
|
|
line <- stateLine updateCur True
|
|
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
|
|
|
|
main :: IO ()
|
|
main = B.mainFromCmdParser $ do
|
|
B.reorderStart
|
|
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
|
|
dropStdout <- B.addSimpleBoolFlag "" ["drop-out"] mempty
|
|
dropStderr <- B.addSimpleBoolFlag "" ["drop-err"] mempty
|
|
dropBoth <- B.addSimpleBoolFlag "" ["drop"] mempty
|
|
conflateStdout <- B.addSimpleBoolFlag "" ["conflate-out"] mempty
|
|
conflateStderr <- B.addSimpleBoolFlag "" ["conflate-err"] mempty
|
|
conflateBoth <- B.addSimpleBoolFlag "" ["conflate"] mempty
|
|
summarize <- B.addFlagStringParams "s" ["summarize"] "PATTERN" mempty
|
|
skip <- B.addFlagStringParams "x" ["skip"] "PATTERN" mempty
|
|
label <- B.addFlagStringParams "" ["label"] "STRING" mempty
|
|
yield <- B.addFlagStringParams "y" ["yield"] "PATTERN" 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")
|
|
-- 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
|
|
(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 -> if null summarize
|
|
then Drop
|
|
else Conflate
|
|
, 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 = (yield <&> \x -> (JoinYield, t x))
|
|
++ (summarize <&> \x -> (JoinSpecific, t x))
|
|
++ (skip <&> \x -> (JoinAll, t x))
|
|
, 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_summary = Nothing
|
|
}
|
|
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
|
|
x <- Text.filter (/= '\r') <$> Text.IO.hGetLine out
|
|
fst teeHandles `forM_` \h -> Text.IO.hPutStrLn h x
|
|
modifyMVar_ stateVar (processLine (StdOut, x))
|
|
let errHandler err = forever $ do
|
|
x <- Text.filter (/= '\r') <$> Text.IO.hGetLine err
|
|
snd teeHandles `forM_` \h -> Text.IO.hPutStrLn h x
|
|
modifyMVar_ stateVar (processLine (StdErr, x))
|
|
let tickHandler = forever $ do
|
|
threadDelay 333333
|
|
modifyMVar_ stateVar $ execStateT $ updateStateLine False
|
|
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
|
|
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_` dispatchLine
|
|
else do
|
|
-- we leave the lines in final state, but process them
|
|
reverse finalLines `forM_` summarizeLines
|
|
gets s_summary >>= \case
|
|
Nothing -> pure ()
|
|
Just (line , JoinedNot ) -> dispatchLine line
|
|
Just (line , JoinedYield) -> dispatchYielded line
|
|
Just ((kind, _), JoinedAll i) -> dispatchSkipped kind i
|
|
Just ((kind, _), Joined i pat prefix) ->
|
|
dispatchPat kind i pat prefix
|
|
finalState <- takeMVar stateVar
|
|
line <- evalStateT (stateLine False False) 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
|
|
|