summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJamesCandy <>2015-08-10 21:19:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-08-10 21:19:00 (GMT)
commita712f1e7e89e3fdb58fb1cedab58189729777416 (patch)
tree2cf6bd5dcb3887dafa52279177beb438d9847c72
parenta5cbe81559d95f838e4a28f966649349c76788de (diff)
version 0.3.0.0HEAD0.3.0.0master
-rw-r--r--Data/Progress.hs143
-rw-r--r--EstProgress.cabal4
2 files changed, 96 insertions, 51 deletions
diff --git a/Data/Progress.hs b/Data/Progress.hs
index 350744b..2ebec4f 100644
--- a/Data/Progress.hs
+++ b/Data/Progress.hs
@@ -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
-
-putBar n prev sz = sequence_ (replicate x (putChar '|')) where
- x = fiftieth n sz - fiftieth prev sz
+{-# NOINLINE active #-}
+active :: MVar Integer
+active = unsafePerformIO (newMVar $ -1)
+
+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 @@ progress f dat = do
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 @@ progress f dat = do
(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 @@ progressWithFile f hdl = do
-- 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-}
+
diff --git a/EstProgress.cabal b/EstProgress.cabal
index fe805b5..8ebfce8 100644
--- a/EstProgress.cabal
+++ b/EstProgress.cabal
@@ -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 @@ cabal-version: >=1.8
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