NorfairKing/feedback
1
1
Fork 0
mirror of https://github.com/NorfairKing/feedback.git synced 2024-11-27 00:47:13 +03:00
Code Issues Projects Releases Wiki Activity

Indicator of how long the loop took

Browse Source
This commit is contained in:
Tom Sydney Kerckhove 2022-03-06 14:05:42 +01:00
parent dac63db4d9
commit e5a0969c0b
3 changed files with 39 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
feedback/src/Feedback/Common/Output.hs
View File

@ -1,12 +1,14 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Feedback.Common.Output where module Feedback.Common.Output where
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time import Data.Time
import Data.Word
import System.Exit import System.Exit
import Text.Colour import Text.Colour
import Text.Printf
putTimedChunks :: TerminalCapabilities -> [Chunk] -> IO () putTimedChunks :: TerminalCapabilities -> [Chunk] -> IO ()
putTimedChunks terminalCapabilities chunks = do putTimedChunks terminalCapabilities chunks = do
@ -16,7 +18,7 @@ putTimedChunks terminalCapabilities chunks = do
putStrLn "" putStrLn ""
indicatorChunk :: String -> Chunk indicatorChunk :: String -> Chunk
indicatorChunk = fore cyan . chunk . T.pack indicatorChunk = fore cyan . chunk . T.pack . printf "%-8s"
loopNameChunk :: String -> Chunk loopNameChunk :: String -> Chunk
loopNameChunk = fore yellow . chunk . T.pack loopNameChunk = fore yellow . chunk . T.pack
@ -25,14 +27,22 @@ commandChunk :: String -> Chunk
commandChunk = fore blue . chunk . T.pack commandChunk = fore blue . chunk . T.pack
exitCodeChunks :: ExitCode -> [Chunk] exitCodeChunks :: ExitCode -> [Chunk]
exitCodeChunks = \case exitCodeChunks ec =
ExitSuccess -> [ indicatorChunk "exited:",
[ fore cyan "exited: ", " ",
" ", case ec of
fore green "success" ExitSuccess ->
] fore green "success"
ExitFailure c -> ExitFailure c ->
[ fore cyan "exited: ", fore red $ chunk $ T.pack $ "failed: " <> show c
" ", ]
fore red $ chunk $ T.pack $ "failed: " <> show c
] durationChunks :: Word64 -> [Chunk]
durationChunks nanosecs =
let diffTime :: Double
diffTime = fromIntegral nanosecs / 1_000_000_000
in [ indicatorChunk "took",
" ",
chunk $
T.pack $ printf "%4.2fs" diffTime
]

14
feedback/src/Feedback/Loop.hs
View File

@ -7,10 +7,12 @@ module Feedback.Loop where
import Control.Monad import Control.Monad
import Data.List import Data.List
import qualified Data.Text as T import qualified Data.Text as T
import Data.Word
import Feedback.Common.OptParse import Feedback.Common.OptParse
import Feedback.Common.Output import Feedback.Common.Output
import Feedback.Common.Process import Feedback.Common.Process
import Feedback.Loop.OptParse import Feedback.Loop.OptParse
import GHC.Clock (getMonotonicTimeNSec)
import Path import Path
import Path.IO import Path.IO
import System.Exit import System.Exit
@ -75,9 +77,13 @@ processWorker command eventChan outputChan = do
let sendOutput = writeChan outputChan let sendOutput = writeChan outputChan
currentProcessVar <- newEmptyMVar currentProcessVar <- newEmptyMVar
let startNewProcess = do let startNewProcess = do
start <- getMonotonicTimeNSec
let endFunc ec = do
end <- getMonotonicTimeNSec
sendOutput $ OutputProcessExited ec (end - start)
processHandle <- processHandle <-
startProcessHandle startProcessHandle
(sendOutput . OutputProcessExited) endFunc
command command
putMVar currentProcessVar processHandle putMVar currentProcessVar processHandle
sendOutput $ OutputProcessStarted command sendOutput $ OutputProcessStarted command
@ -100,7 +106,7 @@ data Output
| OutputKilling | OutputKilling
| OutputKilled | OutputKilled
| OutputProcessStarted !String | OutputProcessStarted !String
| OutputProcessExited !ExitCode | OutputProcessExited !ExitCode !Word64
deriving (Show) deriving (Show)
outputWorker :: OutputSettings -> Chan Output -> IO () outputWorker :: OutputSettings -> Chan Output -> IO ()
@ -131,4 +137,6 @@ outputWorker OutputSettings {..} outputChan = do
" ", " ",
commandChunk command commandChunk command
] ]
OutputProcessExited ec -> put $ exitCodeChunks ec OutputProcessExited ec nanosecs -> do
put $ exitCodeChunks ec
put $ durationChunks nanosecs

5
feedback/src/Feedback/Test.hs
View File

@ -9,6 +9,7 @@ import Feedback.Common.OptParse
import Feedback.Common.Output import Feedback.Common.Output
import Feedback.Common.Process import Feedback.Common.Process
import Feedback.Test.OptParse import Feedback.Test.OptParse
import GHC.Clock (getMonotonicTimeNSec)
import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv) import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv)
runFeedbackTest :: IO () runFeedbackTest :: IO ()
@ -19,5 +20,9 @@ runFeedbackTest = do
forM_ (M.toList testSettingLoops) $ \(loopName, LoopSettings {..}) -> do forM_ (M.toList testSettingLoops) $ \(loopName, LoopSettings {..}) -> do
put [indicatorChunk "testing ", " ", loopNameChunk loopName] put [indicatorChunk "testing ", " ", loopNameChunk loopName]
put [indicatorChunk "starting", " ", commandChunk loopSettingCommand] put [indicatorChunk "starting", " ", commandChunk loopSettingCommand]
start <- getMonotonicTimeNSec
ec <- startProcessAndWait loopSettingCommand ec <- startProcessAndWait loopSettingCommand
end <- getMonotonicTimeNSec
put $ exitCodeChunks ec put $ exitCodeChunks ec
let duration = end - start
put $ durationChunks duration