From 371253337114916cd1d6d1dd18b49553ac76ca3f Mon Sep 17 00:00:00 2001 From: Saurabh Nanda Date: Tue, 29 Sep 2020 15:14:28 +0530 Subject: [PATCH 1/2] attempting a better progress tracking API --- src/Development/Shake.hs | 2 +- src/Development/Shake/Internal/Progress.hs | 9 ++++++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Development/Shake.hs b/src/Development/Shake.hs index ba30db9d4..1a7ddaaa8 100644 --- a/src/Development/Shake.hs +++ b/src/Development/Shake.hs @@ -65,7 +65,7 @@ module Development.Shake( -- ** Targets getTargets, addTarget, withTargetDocs, withoutTargets, -- ** Progress reporting - Progress(..), progressSimple, progressDisplay, progressTitlebar, progressProgram, getProgress, + Progress(..), progressSimple, progressDisplay, progressTitlebar, progressProgram, getProgress, progressTracker, -- ** Verbosity Verbosity(..), getVerbosity, putVerbose, putInfo, putWarn, putError, withVerbosity, quietly, -- * Running commands diff --git a/src/Development/Shake/Internal/Progress.hs b/src/Development/Shake/Internal/Progress.hs index 6d6c22e9a..b68946eda 100644 --- a/src/Development/Shake/Internal/Progress.hs +++ b/src/Development/Shake/Internal/Progress.hs @@ -3,7 +3,7 @@ -- | Progress tracking module Development.Shake.Internal.Progress( progress, - progressSimple, progressDisplay, progressTitlebar, progressProgram, + progressSimple, progressDisplay, progressTitlebar, progressProgram, progressTracker, ProgressEntry(..), progressReplay, writeProgressReport -- INTERNAL USE ONLY ) where @@ -227,6 +227,13 @@ progressDisplay sample disp prog = do maybe "" (", Failure! " ++) (isFailure p) loop time mealy +progressTracker :: Double -> (Progress -> IO ()) -> IO Progress -> IO () +progressTracker sample progHandler prog = do + catchJust (\x -> if x == ThreadKilled then Just () else Nothing) go errHandler + where + go = prog >>= progHandler + errHandler = const go + data ProgressEntry = ProgressEntry {idealSecs :: Double, idealPerc :: Double From 780aec45d07c5489dd31b068f1e56c0a8838811e Mon Sep 17 00:00:00 2001 From: Saurabh Nanda Date: Tue, 29 Sep 2020 15:35:11 +0530 Subject: [PATCH 2/2] bugfix --- src/Development/Shake/Internal/Progress.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Development/Shake/Internal/Progress.hs b/src/Development/Shake/Internal/Progress.hs index b68946eda..c07a5fe68 100644 --- a/src/Development/Shake/Internal/Progress.hs +++ b/src/Development/Shake/Internal/Progress.hs @@ -231,8 +231,12 @@ progressTracker :: Double -> (Progress -> IO ()) -> IO Progress -> IO () progressTracker sample progHandler prog = do catchJust (\x -> if x == ThreadKilled then Just () else Nothing) go errHandler where - go = prog >>= progHandler - errHandler = const go + go = do + p <- prog + progHandler p + sleep sample + go + errHandler = const $ prog >>= progHandler data ProgressEntry = ProgressEntry