From 72d7a1d601ddee8403f7f0d326e97c7a3f58070f Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 8 Dec 2022 18:12:51 +0100 Subject: [PATCH] Capture per-line time taken, improve time output --- src-hxbrief/Main.hs | 234 +++++++++++++++++++++++++++----------------- 1 file changed, 143 insertions(+), 91 deletions(-) diff --git a/src-hxbrief/Main.hs b/src-hxbrief/Main.hs index fadab3f..5784d9e 100644 --- a/src-hxbrief/Main.hs +++ b/src-hxbrief/Main.hs @@ -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