packages feed

EstProgress 0.2.0.0 → 0.3.0.0

raw patch · 2 files changed

+95/−50 lines, 2 filesdep +ansi-terminalPVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal

API changes (from Hackage documentation)

Files

Data/Progress.hs view
@@ -1,36 +1,65 @@-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Unsafe, ScopedTypeVariables #-}
 -- | Progress estimates.
---
---   'progress' is good for functions the recursion trees of which are very unbalanced.
---   'progressWithCalls' is good for functions that consume their input very long
---   before they finish.
 module Data.Progress (progress, progressWithFile, progressWithCalls, progress', progressWithCalls') where
 
 import System.IO.Unsafe
 import System.IO
+import System.Console.ANSI
 import Data.Data
 import Control.Monad.Identity
 import Control.Monad
 import Control.Concurrent
-import Control.Concurrent.MVar
 import Control.Exception
+import Data.List
 
-newtype Size t = Size { unSize :: Int }
+newtype Size t = Size { unSize :: Integer }
 
-size :: (Data t) => t -> Int
+size :: (Data t) => t -> Integer
 size x = unSize (gfoldl (\(Size n) y -> Size (n + size y)) (const (Size 1)) x)
 
-fiftieth x y = x * 50 `quot` y
+{-# NOINLINE active #-}
+active :: MVar Integer
+active = unsafePerformIO (newMVar $ -1)
 
-putBar n prev sz = sequence_ (replicate x (putChar '|')) where
-	x = fiftieth n sz - fiftieth prev sz
+putBar :: Integer -> IO ()
+putBar percent = modifyMVar_ active $ \n ->
+	if n < percent then do
+		setCursorColumn 0
+		let s = show $ min 100 percent
+		putStr $ replicate (3 - length s) ' ' ++ s
+		return percent
+	else
+		return n
 
+-- Prevent simultaneous execution of multiple progress estimates.
+withActive m = do
+	b <- modifyMVar active (\n -> return $ if n == -1 then (0, False) else (n, True))
+	if b then
+		m
+		else
+		finally m (modifyMVar_ active (const $ return $ -1))
+
+fork' m = do
+	caps <- getNumCapabilities
+	if caps >= 2 then
+			void $ forkIO m
+		else
+			void m
+
 -- | Estimate progress based on thunks forced.
-progress f dat = do
-	putChar '['
-	let sz = size dat
+{-# NOINLINE progress #-}
+progress f dat = withActive $ do
+	putStr "\n  0%"
+	sz <- newMVar $ -1
 	count <- newMVar 0
 
+	-- Compute the size in a separate thread, so as not to be embarrassed
+	-- by the parallelism.
+	fork' $ do
+		let s = size dat
+		evaluate s
+		modifyMVar_ sz $ const $ return s
+
 	-- The 'rec' function will make a copy of the input data
 	-- structure, with I/O effects added that print a progress bar
 	-- as the data structure is forced.
@@ -38,10 +67,11 @@ 		rec :: (Data t) => t -> t
 		rec dat = runIdentity $ gfoldl
 			(\(Identity f) x -> unsafePerformIO $ do
+				s <- readMVar sz
 				modifyMVar_ count $ \n ->
-					if n == -1 then do
+					if n /= -1 then do
 						let n' = n + 1
-						putBar n' n sz
+						unless (s == -1) $ putBar (n' * 100 `quot` s)
 						return n'
 					else
 						return n
@@ -58,25 +88,27 @@ 		(do
 		-- Record that the function is done so no more bars are printed.
 		modifyMVar_ count $ const $ return $ -1
-		putStrLn "]")
+		putBar 100
+		putStrLn "")
 
 try' :: IO t -> IO (Either SomeException t)
 try' = try
 
 -- | ...based on amount of file consumed.
-progressWithFile f hdl = do
-	putChar '['
+{-# NOINLINE progressWithFile #-}
+progressWithFile f hdl = withActive $ do
+	putStr "\n  0%"
 
 	-- Check the position of the handle periodically and print
 	-- a progress bar.
 	thd <- try' $ do
 		sz <- liftM fromInteger $ hFileSize hdl
-		forkIO $ foldM_ (\prev () -> do
+		forkIO $ foldM_ (\_ _ -> do
 			n <- liftM fromInteger $ hTell hdl
-			putBar n prev sz
+			putBar (n * 100 `quot` sz)
 			threadDelay 500000
-			return n)
-			0
+			return ())
+			()
 			(repeat ())
 
 	finally
@@ -86,58 +118,71 @@ 		-- Again, prevent the progress bar from being printed once
 		-- the function is done.
 		try' $ either (\_ -> return ()) killThread thd
-		putStrLn "]")
+		putBar 100
+		putStrLn "")
 
 -- | ...based on number of recursive calls.
 --
 --   It returns a result equivalent to that of /fix f x/.
-progressWithCalls f x = do
-	putChar '['
+{-# NOINLINE progressWithCalls #-}
+progressWithCalls f x = withActive $ do
+	putStr "\n  0%"
 
 	-- As the function runs, the procedure will estimate the
-	-- depth and branching factor of the recursion tree.
-	parms <- newMVar (0, 0, 0)
+	-- geometric sequence giving the recursion costs.
+	parms <- newMVar (-1, 20000, 1, 0)
 	let rec depth count x = do
-		modifyMVar_ count $ return . (+1)
-
 		-- Do a recursive call. The call gets a fresh recursion counter.
-		count' <- newMVar 0
+		count' <- newMVar (1, 1)
 		res <- f (rec (depth + 1) count') x
 		evaluate res
 
-		x <- readMVar count'
-		modifyMVar_ parms $ \tup@(mxDep, mxCount, total) -> do
-			-- Calculate the new maxima.
-			let tup'@(mxDep', mxCount', total') = if total < 0 then
+		(x, y) <- readMVar count'
+		modifyMVar_ count $ \(_, z) -> return (y, z + y)
+
+		modifyMVar_ parms $ \tup@(dep, rPrev, yPrev, total) -> do
+			-- Calculate the new parameters.
+			let tup'@(dep', ratio', y', total') = if total < 0 then
 					tup
-				else if x == 0 then
-					(depth `max` mxDep, mxCount, total + 1)
+				else if dep == -1 || depth <= dep then
+					(depth, (4 * rPrev + y * 65536 `quot` x) `quot` 5, y, total + 1)
 				else
-					(mxDep, x `max` mxCount, total + 1)
+					(dep, rPrev, yPrev, total + 1)
 
 			-- Print a progress bar with the new estimate.
-			when (total >= 10) $ putBar
-				(total' * 50
-					`quot` mxCount' ^ (mxDep' + 1))
-				(total * 50
-					`quot` mxCount ^ (mxDep + 1))
-				50
+			when (y' >= 100) $ putBar (total' * 100 * 65536 ^ dep' `quot` (y' * ratio' ^ dep'))
 
 			return tup'
 
 		return res
-	count <- newMVar 0
+	count <- newMVar (1, 1)
 	finally
 		(do
 		res <- rec 0 count x
-		evaluate res
 		return res)
 		(do
-		modifyMVar_ parms $ const $ return (0, 0, -1)
-		putStrLn "]")
+		modifyMVar_ parms $ const $ return (0, 0, 0, -1)
+		putBar 100
+		putStrLn "")
 
 -- | Adapters for pure functions.
+{-# INLINE progress' #-}
 progress' f = progress (return . f)
 
+{-# INLINE progressWithCalls' #-}
 progressWithCalls' f = progressWithCalls (\g -> return . f (unsafePerformIO . g))
+
+{-# RULES
+"progress" forall f (g :: forall t. t -> f t) x. progress (f . progress g) x = g x >>= progress (f . return)
+"progressWithCalls" forall f g. progressWithCalls (f (progressWithCalls g)) = progressWithCalls (\h -> either (g (h . Left)) (f (h . Left) (h . Right))) . Right
+  #-}
+
+{-quicksort _ [] = []
+quicksort f (x:xs) = f tk ++ x : f dr where
+	(tk, dr) = partition (<x) xs
+
+ex :: IO ()
+ex = void $ do
+	rs :: [Int] <- liftM (take 1000000) getRandoms
+	progress' (fix $ \f -> (`using` evalList rseq) . quicksort f) rs-}
EstProgress.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                EstProgress
-version:             0.2.0.0
+version:             0.3.0.0
 synopsis:            Methods for estimating the progress of functions
 description:         Estimates the progress of a function as it executes, and displays a progress bar.
 homepage:            http://alkalisoftware.net
@@ -18,4 +18,4 @@ library
   exposed-modules:     Data.Progress
   -- other-modules:       
-  build-depends:       base >=4 && <=5, mtl >=1.1
+  build-depends:       base >=4 && <=5, mtl >= 1.1, ansi-terminal >= 0.6.2.1