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

Capture per-line time taken, improve time output

master
Lennart Spitzner 2022-12-08 18:12:51 +01:00
parent 0878254f71
commit 72d7a1d601
1 changed files with 143 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

234
src-hxbrief/Main.hs
View File

@ -125,33 +125,41 @@ data State = State
{ s_config :: Config { s_config :: Config
, s_regions :: [ConsoleRegion] , s_regions :: [ConsoleRegion]
, s_history :: [(StreamKind, Text)] , s_history :: [(StreamKind, Text)]
, s_lines :: [(StreamKind, Text)] , s_lines :: [(StreamKind, Text, Float)]
, s_countOut :: Int , s_countOut :: Int
, s_countErr :: Int , s_countErr :: Int
, s_globalStart :: TimeSpec , s_globalStart :: TimeSpec
, s_lastLineTime :: 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) -- bumpLineTime :: StateT State IO ()
getTimeDiff updateCur = do -- 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 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 s <- get
let diffNanos1 = toNanoSecs $ diffTimeSpec (s_globalStart s) now let diffFloat1 = diffTimes (s_globalStart s) (s_nowTime s)
let diffNanos2 = toNanoSecs $ diffTimeSpec (s_lastLineTime s) now let diffFloat2 = diffTimes (s_lastLineTime s) (s_nowTime s)
pure let outStr = if False && diffFloat2 > 1.0
( 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 then t $ printf
"waiting since %0.0fs … %0.1fs total, %i/%i lines stdout/stderr" "waiting since %0.0fs … %0.1fs total, %i/%i lines stdout/stderr"
diffFloat2 diffFloat2
@ -238,8 +246,8 @@ dispatchSkipped oldKind i = do
StdErr -> when (c_keepStderr conf /= Drop) $ errorConcurrent prettyPat StdErr -> when (c_keepStderr conf /= Drop) $ errorConcurrent prettyPat
summarizeLines :: (StreamKind, Text) -> StateT State IO () summarizeLines :: (StreamKind, Text, Float) -> StateT State IO ()
summarizeLines cur@(kind, line) = 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 :: Maybe (JoinMode, Text) =
@ -260,7 +268,8 @@ summarizeLines cur@(kind, line) = do
case (s_summary s, match) of case (s_summary s, match) of
(Nothing, _) -> put s (Nothing, _) -> put s
{ s_summary = Just { s_summary = Just
( cur ( kind
, line
, case match of , case match of
Nothing -> JoinedNot Nothing -> JoinedNot
Just (JoinYield , _ ) -> JoinedYield Just (JoinYield , _ ) -> JoinedYield
@ -268,11 +277,12 @@ summarizeLines cur@(kind, line) = do
Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line)
) )
} }
(Just (oldLine, JoinedNot), _) -> do (Just (oldKind, oldLine, JoinedNot), _) -> do
dispatchLine oldLine dispatchLine (oldKind, oldLine)
put s put s
{ s_summary = Just { s_summary = Just
( cur ( kind
, line
, case match of , case match of
Nothing -> JoinedNot Nothing -> JoinedNot
Just (JoinYield , _ ) -> JoinedYield Just (JoinYield , _ ) -> JoinedYield
@ -280,14 +290,15 @@ summarizeLines cur@(kind, line) = do
Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line)
) )
} }
(Just (oldLine, JoinedYield), Nothing) -> do (Just (oldKind, oldLine, JoinedYield), Nothing) -> do
dispatchYielded oldLine dispatchYielded (oldKind, oldLine)
put s { s_summary = Just (cur, JoinedNot) } put s { s_summary = Just (kind, line, JoinedNot) }
(Just (oldLine, JoinedYield), _) -> do (Just (oldKind, oldLine, JoinedYield), _) -> do
dispatchYielded oldLine dispatchYielded (oldKind, oldLine)
put s put s
{ s_summary = Just { s_summary = Just
( cur ( kind
, line
, case match of , case match of
Nothing -> JoinedNot Nothing -> JoinedNot
Just (JoinAll , _ ) -> JoinedAll 1 Just (JoinAll , _ ) -> JoinedAll 1
@ -295,26 +306,26 @@ summarizeLines cur@(kind, line) = do
Just (JoinYield , _ ) -> JoinedYield Just (JoinYield , _ ) -> JoinedYield
) )
} }
(Just ((oldKind, _), JoinedAll i), Nothing) -> do (Just (oldKind, _, JoinedAll i), Nothing) -> do
dispatchSkipped oldKind i dispatchSkipped oldKind i
put s { s_summary = Just (cur, JoinedNot) } put s { s_summary = Just (kind, line, JoinedNot) }
(Just ((oldKind, _), Joined i oldPat oldPrefix), Nothing) -> do (Just (oldKind, _, Joined i oldPat oldPrefix), Nothing) -> do
dispatchPat oldKind i oldPat oldPrefix dispatchPat oldKind i oldPat oldPrefix
put s { s_summary = Just (cur, JoinedNot) } put s { s_summary = Just (kind, line, JoinedNot) }
(Just ((oldKind, _), JoinedAll i), Just joiner) -> case joiner of (Just (oldKind, _, JoinedAll i), Just joiner) -> case joiner of
(JoinYield, _pat) -> do (JoinYield, _pat) -> do
dispatchSkipped oldKind i dispatchSkipped oldKind i
put s { s_summary = Just (cur, JoinedYield) } put s { s_summary = Just (kind, line, JoinedYield) }
(JoinAll, _) (JoinAll, _)
| kind == oldKind -> do | kind == oldKind -> do
put s { s_summary = Just (cur, JoinedAll (i + 1)) } put s { s_summary = Just (kind, line, JoinedAll (i + 1)) }
| otherwise -> do | otherwise -> do
dispatchSkipped oldKind i dispatchSkipped oldKind i
put s { s_summary = Just (cur, JoinedAll 1) } put s { s_summary = Just (kind, line, JoinedAll 1) }
(JoinSpecific, pat) -> do (JoinSpecific, pat) -> do
dispatchSkipped oldKind i dispatchSkipped oldKind i
put s { s_summary = Just (cur, 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) -> (Just (oldKind, _, Joined i oldPat oldPrefix), Just joiner) ->
case joiner of case joiner of
(JoinSpecific, pat) | oldPat == pat && kind == oldKind -> do (JoinSpecific, pat) | oldPat == pat && kind == oldKind -> do
let newPrefix = let newPrefix =
@ -322,12 +333,13 @@ summarizeLines cur@(kind, line) = do
go ((a, b) : rest) | a == b = a : go rest go ((a, b) : rest) | a == b = a : go rest
| otherwise = [] | otherwise = []
in go $ zip oldPrefix (Text.words line) 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 _ -> do
dispatchPat oldKind i oldPat oldPrefix dispatchPat oldKind i oldPat oldPrefix
put s put s
{ s_summary = Just { s_summary = Just
( cur ( kind
, line
, case joiner of , case joiner of
(JoinYield , _ ) -> JoinedYield (JoinYield , _ ) -> JoinedYield
(JoinAll , _ ) -> JoinedAll 1 (JoinAll , _ ) -> JoinedAll 1
@ -336,39 +348,56 @@ summarizeLines cur@(kind, line) = do
} }
processLine :: (StreamKind, Text) -> State -> IO State prettyLine :: Config -> (StreamKind, Text, Float) -> Text
processLine newPair@(kind, _) = execStateT $ do 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 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 do
s0 <- get s0 <- get
let (keep, over) = splitAt (c_lines conf - 1) (s_lines s0) let (keep, over) = splitAt (c_lines conf - 1) (s_lines s0)
put s0 { s_lines = keep } put s0 { s_lines = keep }
over `forM_` summarizeLines over `forM_` summarizeLines
case kind of case newKind of
StdOut -> modify $ \s -> s { s_countOut = s_countOut s + 1 } StdOut -> modify $ \s -> s { s_countOut = s_countOut s + 1 }
StdErr -> modify $ \s -> s { s_countErr = s_countErr s + 1 } StdErr -> modify $ \s -> s { s_countErr = s_countErr s + 1 }
curLines <- gets s_lines curLines <- gets s_lines
prettyLinesWithSummary <- do prettyLinesWithSummary <- do
let ellipse :: Text -> Text let prettyLines =
ellipse input = reverse $ take (c_lines conf) curLines <&> prettyLine conf
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 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 line) : prettyLines (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just ((StdOut, line), JoinedAll 1) -> Just (StdOut, line, JoinedAll 1) ->
(fWhiteDis <> t "│ " <> fReset <> ellipse 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
@ -378,9 +407,9 @@ processLine newPair@(kind, _) = execStateT $ do
<> fReset <> fReset
) )
: prettyLines : prettyLines
Just ((StdOut, line), Joined 1 _ _) -> Just (StdOut, line, Joined 1 _ _) ->
(fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just ((StdOut, _), Joined i pat _) -> Just (StdOut, _, Joined i pat _) ->
( fWhiteDis ( fWhiteDis
<> t "│ " <> t "│ "
<> fReset <> fReset
@ -392,15 +421,15 @@ processLine newPair@(kind, _) = execStateT $ do
<> fReset <> fReset
) )
: prettyLines : prettyLines
Just ((StdOut, line), JoinedYield) -> Just (StdOut, line, JoinedYield) ->
(fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just ((StdErr, line), JoinedNot) -> Just (StdErr, line, JoinedNot) ->
(fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just ((StdErr, line), JoinedYield) -> Just (StdErr, line, JoinedYield) ->
(fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just ((StdErr, line), JoinedAll 1) -> Just (StdErr, line, JoinedAll 1) ->
(fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just ((StdErr, _line), JoinedAll i) -> Just (StdErr, _line, JoinedAll i) ->
( fRedDis ( fRedDis
<> t "│ " <> t "│ "
<> fGrey <> fGrey
@ -410,9 +439,9 @@ processLine newPair@(kind, _) = execStateT $ do
<> fReset <> fReset
) )
: prettyLines : prettyLines
Just ((StdErr, line), Joined 1 _ _) -> Just (StdErr, line, Joined 1 _ _) ->
(fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
Just ((StdErr, _), Joined i pat _) -> Just (StdErr, _, Joined i pat _) ->
( fRedDis ( fRedDis
<> t "│ " <> t "│ "
<> fReset <> fReset
@ -439,11 +468,29 @@ processLine newPair@(kind, _) = execStateT $ do
) )
prettyLinesWithSummary prettyLinesWithSummary
(take showCount regions) (take showCount regions)
updateStateLine True updateStateLine
updateStateLine :: Bool -> StateT State IO () updateLastLine :: StateT State IO ()
updateStateLine updateCur = do updateLastLine = do
line <- stateLine updateCur True 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 s <- get
liftIO $ setConsoleRegion liftIO $ setConsoleRegion
(last $ s_regions s) (last $ s_regions s)
@ -642,6 +689,7 @@ main = B.mainFromCmdParser $ do
, s_countErr = 0 , s_countErr = 0
, s_globalStart = startTime , s_globalStart = startTime
, s_lastLineTime = startTime , s_lastLineTime = startTime
, s_nowTime = startTime
, s_summary = Nothing , s_summary = Nothing
} }
stateVar :: MVar State <- newMVar initialState stateVar :: MVar State <- newMVar initialState
@ -659,14 +707,17 @@ main = B.mainFromCmdParser $ do
let outHandler out = forever $ do let outHandler out = forever $ do
x <- Text.filter (/= '\r') <$> Text.IO.hGetLine out x <- Text.filter (/= '\r') <$> Text.IO.hGetLine out
fst teeHandles `forM_` \h -> Text.IO.hPutStrLn h x fst teeHandles `forM_` \h -> Text.IO.hPutStrLn h x
modifyMVar_ stateVar (processLine (StdOut, x)) modifyMVar_ stateVar (processLine StdOut x)
let errHandler err = forever $ do let errHandler err = forever $ do
x <- Text.filter (/= '\r') <$> Text.IO.hGetLine err x <- Text.filter (/= '\r') <$> Text.IO.hGetLine err
snd teeHandles `forM_` \h -> Text.IO.hPutStrLn h x snd teeHandles `forM_` \h -> Text.IO.hPutStrLn h x
modifyMVar_ stateVar (processLine (StdErr, x)) modifyMVar_ stateVar (processLine StdErr x)
let tickHandler = forever $ do let tickHandler = forever $ do
threadDelay 333333 threadDelay 333333
modifyMVar_ stateVar $ execStateT $ updateStateLine False modifyMVar_ stateVar
$ 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")])
@ -698,19 +749,20 @@ main = B.mainFromCmdParser $ do
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_` dispatchLine 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 (line , JoinedNot ) -> dispatchLine line Just (kind, line, JoinedNot ) -> dispatchLine (kind, line)
Just (line , JoinedYield) -> dispatchYielded line Just (kind, line, JoinedYield) -> dispatchYielded (kind, line)
Just ((kind, _), JoinedAll i) -> dispatchSkipped kind i Just (kind, _ , JoinedAll i) -> 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 (stateLine False False) 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 fGrey