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..c07a5fe68 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,17 @@ 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 = do
+      p <- prog
+      progHandler p
+      sleep sample
+      go
+    errHandler = const $ prog >>= progHandler
+
 
 data ProgressEntry = ProgressEntry
     {idealSecs :: Double, idealPerc :: Double