Capture per-line time taken, improve time output
parent
0878254f71
commit
72d7a1d601
|
|
@ -125,33 +125,41 @@ data State = State
|
|||
{ s_config :: Config
|
||||
, s_regions :: [ConsoleRegion]
|
||||
, s_history :: [(StreamKind, Text)]
|
||||
, s_lines :: [(StreamKind, Text)]
|
||||
, s_lines :: [(StreamKind, Text, Float)]
|
||||
, s_countOut :: Int
|
||||
, s_countErr :: Int
|
||||
, s_globalStart :: TimeSpec
|
||||
, s_lastLineTime :: TimeSpec
|
||||
, s_summary :: Maybe ((StreamKind, Text), JoinedInfo)
|
||||
, s_nowTime :: TimeSpec
|
||||
, s_summary :: Maybe (StreamKind, Text, JoinedInfo)
|
||||
}
|
||||
|
||||
|
||||
getTimeDiff :: Bool -> StateT State IO (Float, Float)
|
||||
getTimeDiff updateCur = do
|
||||
-- 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
|
||||
when updateCur $ modify $ \s -> s { s_lastLineTime = now }
|
||||
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 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
|
||||
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
|
||||
|
|
@ -238,8 +246,8 @@ dispatchSkipped oldKind i = do
|
|||
StdErr -> when (c_keepStderr conf /= Drop) $ errorConcurrent prettyPat
|
||||
|
||||
|
||||
summarizeLines :: (StreamKind, Text) -> StateT State IO ()
|
||||
summarizeLines cur@(kind, line) = do
|
||||
summarizeLines :: (StreamKind, Text, Float) -> StateT State IO ()
|
||||
summarizeLines (kind, line, _linetime) = do
|
||||
s <- get
|
||||
let conf = s_config s
|
||||
let match :: Maybe (JoinMode, Text) =
|
||||
|
|
@ -260,7 +268,8 @@ summarizeLines cur@(kind, line) = do
|
|||
case (s_summary s, match) of
|
||||
(Nothing, _) -> put s
|
||||
{ s_summary = Just
|
||||
( cur
|
||||
( kind
|
||||
, line
|
||||
, case match of
|
||||
Nothing -> JoinedNot
|
||||
Just (JoinYield , _ ) -> JoinedYield
|
||||
|
|
@ -268,11 +277,12 @@ summarizeLines cur@(kind, line) = do
|
|||
Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line)
|
||||
)
|
||||
}
|
||||
(Just (oldLine, JoinedNot), _) -> do
|
||||
dispatchLine oldLine
|
||||
(Just (oldKind, oldLine, JoinedNot), _) -> do
|
||||
dispatchLine (oldKind, oldLine)
|
||||
put s
|
||||
{ s_summary = Just
|
||||
( cur
|
||||
( kind
|
||||
, line
|
||||
, case match of
|
||||
Nothing -> JoinedNot
|
||||
Just (JoinYield , _ ) -> JoinedYield
|
||||
|
|
@ -280,14 +290,15 @@ summarizeLines cur@(kind, line) = do
|
|||
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
|
||||
(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
|
||||
( cur
|
||||
( kind
|
||||
, line
|
||||
, case match of
|
||||
Nothing -> JoinedNot
|
||||
Just (JoinAll , _ ) -> JoinedAll 1
|
||||
|
|
@ -295,26 +306,26 @@ summarizeLines cur@(kind, line) = do
|
|||
Just (JoinYield , _ ) -> JoinedYield
|
||||
)
|
||||
}
|
||||
(Just ((oldKind, _), JoinedAll i), Nothing) -> do
|
||||
(Just (oldKind, _, JoinedAll i), Nothing) -> do
|
||||
dispatchSkipped oldKind i
|
||||
put s { s_summary = Just (cur, JoinedNot) }
|
||||
(Just ((oldKind, _), Joined i oldPat oldPrefix), Nothing) -> do
|
||||
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 (cur, JoinedNot) }
|
||||
(Just ((oldKind, _), JoinedAll i), Just joiner) -> case joiner of
|
||||
put s { s_summary = Just (kind, line, JoinedNot) }
|
||||
(Just (oldKind, _, JoinedAll i), Just joiner) -> case joiner of
|
||||
(JoinYield, _pat) -> do
|
||||
dispatchSkipped oldKind i
|
||||
put s { s_summary = Just (cur, JoinedYield) }
|
||||
put s { s_summary = Just (kind, line, JoinedYield) }
|
||||
(JoinAll, _)
|
||||
| kind == oldKind -> do
|
||||
put s { s_summary = Just (cur, JoinedAll (i + 1)) }
|
||||
put s { s_summary = Just (kind, line, JoinedAll (i + 1)) }
|
||||
| otherwise -> do
|
||||
dispatchSkipped oldKind i
|
||||
put s { s_summary = Just (cur, JoinedAll 1) }
|
||||
put s { s_summary = Just (kind, line, 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) ->
|
||||
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 =
|
||||
|
|
@ -322,12 +333,13 @@ summarizeLines cur@(kind, line) = do
|
|||
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) }
|
||||
put s { s_summary = Just (kind, line, Joined (i + 1) pat newPrefix) }
|
||||
_ -> do
|
||||
dispatchPat oldKind i oldPat oldPrefix
|
||||
put s
|
||||
{ s_summary = Just
|
||||
( cur
|
||||
( kind
|
||||
, line
|
||||
, case joiner of
|
||||
(JoinYield , _ ) -> JoinedYield
|
||||
(JoinAll , _ ) -> JoinedAll 1
|
||||
|
|
@ -336,39 +348,56 @@ summarizeLines cur@(kind, line) = do
|
|||
}
|
||||
|
||||
|
||||
processLine :: (StreamKind, Text) -> State -> IO State
|
||||
processLine newPair@(kind, _) = execStateT $ do
|
||||
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
|
||||
modify $ \s -> s { s_lines = newPair : s_lines s }
|
||||
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 kind of
|
||||
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 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
|
||||
let prettyLines =
|
||||
reverse $ take (c_lines conf) curLines <&> prettyLine conf
|
||||
|
||||
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) ->
|
||||
Just (StdOut, line, JoinedNot) ->
|
||||
(fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
||||
Just (StdOut, line, JoinedAll 1) ->
|
||||
(fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
||||
Just (StdOut, _line, JoinedAll i) ->
|
||||
( fWhiteDis
|
||||
<> t "│ "
|
||||
<> fGrey
|
||||
|
|
@ -378,9 +407,9 @@ processLine newPair@(kind, _) = execStateT $ do
|
|||
<> fReset
|
||||
)
|
||||
: prettyLines
|
||||
Just ((StdOut, line), Joined 1 _ _) ->
|
||||
(fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
|
||||
Just ((StdOut, _), Joined i pat _) ->
|
||||
Just (StdOut, line, Joined 1 _ _) ->
|
||||
(fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
||||
Just (StdOut, _, Joined i pat _) ->
|
||||
( fWhiteDis
|
||||
<> t "│ "
|
||||
<> fReset
|
||||
|
|
@ -392,15 +421,15 @@ processLine newPair@(kind, _) = execStateT $ do
|
|||
<> 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) ->
|
||||
Just (StdOut, line, JoinedYield) ->
|
||||
(fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
||||
Just (StdErr, line, JoinedNot) ->
|
||||
(fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
||||
Just (StdErr, line, JoinedYield) ->
|
||||
(fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
||||
Just (StdErr, line, JoinedAll 1) ->
|
||||
(fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
||||
Just (StdErr, _line, JoinedAll i) ->
|
||||
( fRedDis
|
||||
<> t "│ "
|
||||
<> fGrey
|
||||
|
|
@ -410,9 +439,9 @@ processLine newPair@(kind, _) = execStateT $ do
|
|||
<> fReset
|
||||
)
|
||||
: prettyLines
|
||||
Just ((StdErr, line), Joined 1 _ _) ->
|
||||
(fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
|
||||
Just ((StdErr, _), Joined i pat _) ->
|
||||
Just (StdErr, line, Joined 1 _ _) ->
|
||||
(fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
|
||||
Just (StdErr, _, Joined i pat _) ->
|
||||
( fRedDis
|
||||
<> t "│ "
|
||||
<> fReset
|
||||
|
|
@ -439,11 +468,29 @@ processLine newPair@(kind, _) = execStateT $ do
|
|||
)
|
||||
prettyLinesWithSummary
|
||||
(take showCount regions)
|
||||
updateStateLine True
|
||||
updateStateLine
|
||||
|
||||
updateStateLine :: Bool -> StateT State IO ()
|
||||
updateStateLine updateCur = do
|
||||
line <- stateLine updateCur True
|
||||
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)
|
||||
|
|
@ -642,6 +689,7 @@ main = B.mainFromCmdParser $ do
|
|||
, s_countErr = 0
|
||||
, s_globalStart = startTime
|
||||
, s_lastLineTime = startTime
|
||||
, s_nowTime = startTime
|
||||
, s_summary = Nothing
|
||||
}
|
||||
stateVar :: MVar State <- newMVar initialState
|
||||
|
|
@ -659,14 +707,17 @@ main = B.mainFromCmdParser $ do
|
|||
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))
|
||||
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))
|
||||
modifyMVar_ stateVar (processLine StdErr x)
|
||||
let tickHandler = forever $ do
|
||||
threadDelay 333333
|
||||
modifyMVar_ stateVar $ execStateT $ updateStateLine False
|
||||
modifyMVar_ stateVar
|
||||
$ execStateT
|
||||
$ updateLastLine
|
||||
>> updateStateLine
|
||||
innerEnv <- do
|
||||
env <- System.Environment.getEnvironment
|
||||
pure (env ++ [("IN_HXBRIEF", "1")])
|
||||
|
|
@ -698,19 +749,20 @@ main = B.mainFromCmdParser $ do
|
|||
then do
|
||||
modify
|
||||
$ \s -> s { s_config = (s_config s) { c_keepStderr = Keep } }
|
||||
reverse finalLines `forM_` dispatchLine
|
||||
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 (line , JoinedNot ) -> dispatchLine line
|
||||
Just (line , JoinedYield) -> dispatchYielded line
|
||||
Just ((kind, _), JoinedAll i) -> dispatchSkipped kind i
|
||||
Just ((kind, _), Joined i pat prefix) ->
|
||||
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
|
||||
finalState <- takeMVar stateVar
|
||||
line <- evalStateT (stateLine False False) finalState
|
||||
line <- evalStateT (bumpNowTime >> stateLine) finalState
|
||||
s_regions finalState `forM_` \r -> closeConsoleRegion r
|
||||
let prefix =
|
||||
fGrey
|
||||
|
|
|
|||
Loading…
Reference in New Issue