Remove isRunning, signal completion by killing the progress reporting…

… thread, ensures Finished messages always appear instantly

CHANGES.txt

@@ -1,5 +1,6 @@
 Changelog for Shake
 
+    Remove isRunning, kill the progress thread on completion
     #47, improve the perform on ?==, especially on "//*"
     #68, improve the docs for addOracle
     #55, ensure if you need phony targets you rebuild every time

Development/Shake/Core.hs

@@ -293,21 +293,26 @@ run opts@ShakeOptions{..} rs = (if shakeLineBuffering then lineBuffering else id
                 ,("Got",Just now)]
                 ""
 
-    running <- newIORef True
+    progressThread <- newIORef Nothing
     after <- newIORef []
-    flip finally (writeIORef running False >> if shakeTimings then printTimings else resetTimings) $
+    let cleanup = do
+            flip whenJust killThread =<< readIORef progressThread
+            when shakeTimings printTimings
+            resetTimings -- so we don't leak memory
+    flip finally cleanup $
         withCapabilities shakeThreads $ do
             withDatabase opts diagnostic $ \database -> do
-                forkIO $ shakeProgress $ do
-                    running <- readIORef running
+                tid <- forkIO $ shakeProgress $ do
                     failure <- fmap (fmap fst) $ readIORef except
                     stats <- progress database
-                    return stats{isRunning=running, isFailure=failure}
+                    return stats{isFailure=failure}
+                writeIORef progressThread $ Just tid
                 let ruleinfo = createRuleinfo rs
                 addTiming "Running rules"
                 runPool (shakeThreads == 1) shakeThreads $ \pool -> do
                     let s0 = SAction database pool start ruleinfo output shakeVerbosity diagnostic lint after emptyStack [] 0 [] Nothing
                     mapM_ (addPool pool . staunch . runAction s0) (actions rs)
+
                 when shakeLint $ do
                     addTiming "Lint checking"
                     checkValid database (runStored ruleinfo)

Development/Shake/Progress.hs

@@ -39,8 +39,7 @@ foreign import stdcall "Windows.h SetConsoleTitleA" c_setConsoleTitle :: LPCSTR
 --   to 'Development.Shake.shakeProgress'. Typically a program will use 'progressDisplay' to poll this value and produce
 --   status messages, which is implemented using this data type.
 data Progress = Progress
-    {isRunning :: !Bool -- ^ Starts out 'True', becomes 'False' once the build has completed.
-    ,isFailure :: !(Maybe String) -- ^ Starts out 'Nothing', becomes 'Just' a target name if a rule fails.
+    {isFailure :: !(Maybe String) -- ^ Starts out 'Nothing', becomes 'Just' a target name if a rule fails.
     ,countSkipped :: {-# UNPACK #-} !Int -- ^ Number of rules which were required, but were already in a valid state.
     ,countBuilt :: {-# UNPACK #-} !Int -- ^ Number of rules which were have been built in this run.
     ,countUnknown :: {-# UNPACK #-} !Int -- ^ Number of rules which have been built previously, but are not yet known to be required.
@@ -53,10 +52,9 @@ data Progress = Progress
     deriving (Eq,Ord,Show,Data,Typeable)
 
 instance Monoid Progress where
-    mempty = Progress True Nothing 0 0 0 0 0 0 0 (0,0)
+    mempty = Progress Nothing 0 0 0 0 0 0 0 (0,0)
     mappend a b = Progress
-        {isRunning = isRunning a && isRunning b
-        ,isFailure = isFailure a `mplus` isFailure b
+        {isFailure = isFailure a `mplus` isFailure b
         ,countSkipped = countSkipped a + countSkipped b
         ,countBuilt = countBuilt a + countBuilt b
         ,countUnknown = countUnknown a + countUnknown b
@@ -198,18 +196,15 @@ progressDisplayTester = progressDisplayer False
 progressDisplayer :: Bool -> Double -> (String -> IO ()) -> IO Progress -> IO ()
 progressDisplayer sleep sample disp prog = do
     disp "Starting..." -- no useful info at this stage
-    loop $ message sample idStream
+    catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop $ message sample idStream) (const $ disp "Finished")
     where
         loop :: Stream Progress String -> IO ()
         loop stream = do
             when sleep $ threadDelay $ ceiling $ sample * 1000000
             p <- prog
-            if not $ isRunning p then
-                disp "Finished"
-             else do
-                (msg, stream) <- return $ runStream stream p
-                disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)
-                loop stream
+            (msg, stream) <- return $ runStream stream p
+            disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)
+            loop stream
 
 
 {-# NOINLINE xterm #-}

Development/Shake/Types.hs

@@ -86,7 +86,8 @@ data ShakeOptions = ShakeOptions
     ,shakeTimings :: Bool
         -- ^ Default to 'False'. Print timing information for each stage at the end.
     ,shakeProgress :: IO Progress -> IO ()
-        -- ^ Defaults to no action. A function called on a separate thread when the build starts, allowing progress to be reported.
+        -- ^ Defaults to no action. A function called when the build starts, allowing progress to be reported.
+        --   The function is called on a separate thread, and that thread is killed when the build completes.
         --   For applications that want to display progress messages, 'progressSimple' is often sufficient, but more advanced
         --   users should look at the 'Progress' data type.
     ,shakeOutput :: Verbosity -> String -> IO ()

Examples/Test/Progress.hs

@@ -1,8 +1,11 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 
 module Examples.Test.Progress(main) where
 
 import Development.Shake.Progress
+import Development.Shake.Classes
 import Examples.Util
+import Control.Exception hiding (assert)
 import Data.IORef
 import Data.Monoid
 import Data.Char
@@ -14,21 +17,26 @@ main = shaken test $ \args obj -> return ()
 -- | Given a list of todo times, get out a list of how long is predicted
 prog = progEx 10000000000000000
 
+data MyException = MyException deriving (Show, Typeable)
+instance Exception MyException
+
+
 progEx :: Double -> [Double] -> IO [Double]
 progEx mxDone todo = do
     let resolution = 10000 -- Use resolution to get extra detail on the numbers
     let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tail todo)
     pile <- newIORef $ tail $ zipWith (\t d -> mempty{timeBuilt=d*resolution,timeTodo=(t*resolution,0)}) todo done
     let get = do a <- readIORef pile
                  case a of
-                     [] -> return mempty{isRunning=False}
+                     [] -> throw MyException
                      x:xs -> do writeIORef pile xs; return x
 
     out <- newIORef []
     let put x = do let (mins,secs) = break (== 'm') $ takeWhile (/= '(') x
                    let f x = let y = filter isDigit x in if null y then 0/0 else read y
                    modifyIORef out (++ [(if null secs then f mins else f mins * 60 + f secs) / resolution])
-    progressDisplayTester resolution put get
+    -- we abort by killing the thread, but then catch the abort and resume normally
+    catch (progressDisplayTester resolution put get) $ \MyException -> return ()
     fmap (take $ length todo) $ readIORef out