module Data.Progress (progress, progressWithFile, progressWithCalls, progress', progressWithCalls') where
import System.IO.Unsafe
import System.IO
import Data.Data
import Control.Monad.Identity
import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception
newtype Size t = Size { unSize :: Int }
size :: (Data t) => t -> Int
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
progress f dat = do
putChar '['
let sz = size dat
count <- newMVar 0
let
rec :: (Data t) => t -> t
rec dat = runIdentity $ gfoldl
(\(Identity f) x -> unsafePerformIO $ do
modifyMVar_ count $ \n ->
if n == 1 then do
let n' = n + 1
putBar n' n sz
return n'
else
return n
return $ Identity $ f $ rec x)
Identity
dat
finally
(do
res <- f $ rec dat
return $! res)
(do
modifyMVar_ count $ const $ return $ 1
putStrLn "]")
try' :: IO t -> IO (Either SomeException t)
try' = try
progressWithFile f hdl = do
putChar '['
thd <- try' $ do
sz <- liftM fromInteger $ hFileSize hdl
forkIO $ foldM_ (\prev () -> do
n <- liftM fromInteger $ hTell hdl
putBar n prev sz
threadDelay 500000
return n)
0
(repeat ())
finally
(f hdl)
(do
try' $ either (\_ -> return ()) killThread thd
putStrLn "]")
progressWithCalls f x = do
putChar '['
parms <- newMVar (0, 0, 0)
let rec depth count x = do
modifyMVar_ count $ return . (+1)
count' <- newMVar 0
res <- f (rec (depth + 1) count') x
return $! res
x <- readMVar count'
modifyMVar_ parms $ \tup@(mxDep, mxCount, total) -> do
let tup'@(mxDep', mxCount', total') = if total < 0 then
tup
else if x == 0 then
(depth `max` mxDep, mxCount, total + 1)
else
(mxDep, x `max` mxCount, total + 1)
when (total >= 10) $ putBar
(total' * 50
`quot` mxCount' ^ (mxDep' + 1))
(total * 50
`quot` mxCount ^ (mxDep + 1))
50
return tup'
return res
count <- newMVar 0
finally
(do
res <- rec 0 count x
return $! res)
(do
modifyMVar_ parms $ const $ return (0, 0, 1)
putStrLn "]")
progress' f = progress (return . f)
progressWithCalls' f = progressWithCalls (\g -> return . f (unsafePerformIO . g))