1{-# LANGUAGE Safe #-} 2{- 3Copyright (c) 2006-2011 John Goerzen <jgoerzen@complete.org> 4 5All rights reserved. 6 7For license and copyright information, see the file LICENSE 8-} 9 10{- | 11 Module : Data.Progress.Tracker 12 Copyright : Copyright (C) 2006-2011 John Goerzen 13 SPDX-License-Identifier: BSD-3-Clause 14 15 Stability : provisional 16 Portability: portable 17 18Tools for tracking the status of a long operation. 19 20Written by John Goerzen, jgoerzen\@complete.org 21 22See also "Data.Progress.Meter" -} 23 24module Data.Progress.Tracker ( 25 -- * Introduction 26 -- $introduction 27 -- ** Examples 28 -- $examples 29 -- * Creation and Options 30 newProgress, newProgress', 31 addCallback, addParent, 32 -- * Updating 33 incrP, incrP', setP, setP', incrTotal, 34 setTotal, finishP, 35 -- * Reading and Processing 36 getSpeed, 37 withStatus, 38 getETR, 39 getETA, 40 -- * Types 41 ProgressStatus(..), 42 Progress, ProgressTimeSource, 43 ProgressCallback, 44 ProgressStatuses, 45 -- * Utilities 46 defaultTimeSource 47 ) 48 49where 50import Control.Concurrent.MVar 51import System.Time 52import System.Time.Utils 53import Data.Ratio 54 55{- $introduction 56 57ProgressTracker is a module for tracking the progress on long-running 58operations. It can be thought of as the back end engine behind 59a status bar. ProgressTracker can do things such as track how far along 60a task is, provide an estimated time of completion, estimated time remaining, 61current speed, etc. It is designed to be as generic as possible; it can even 62base its speed calculations on something other than the system clock. 63 64ProgressTracker also supports a notion of a parent tracker. This is used when 65a large task is composed of several individual tasks which may also be 66long-running. Downloading many large files over the Internet is a common 67example of this. 68 69Any given ProgressTracker can be told about one or more parent trackers. 70When the child tracker's status is updated, the parent tracker's status is 71also updated in the same manner. Therefore, the progress on each individual 72component, as well as the overall progress, can all be kept in sync 73automatically. 74 75Finally, you can register callbacks. Callbacks are functions that are called 76whenever the status of a tracker changes. They'll be passed the old and new 77status and are intended to do things like update on-screen status displays. 78 79The cousin module 'Data.Progress.Meter' can be used to nicely render 80these trackers on a console. 81-} 82 83{- $examples 84 85Here is an example use: 86 87>do prog <- newProgress "mytracker" 1024 88> incrP prog 10 89> getETR prog >>= print -- prints number of seconds remaining 90> incrP prog 500 91> finishP prog 92-} 93 94---------------------------------------------------------------------- 95-- TYPES 96---------------------------------------------------------------------- 97 98{- | A function that, when called, yields the current time. 99The default is 'defaultTimeSource'. -} 100type ProgressTimeSource = IO Integer 101 102{- | The type for a callback function for the progress tracker. 103When given at creation time to 'newProgress\'' or when added via 'addCallback', 104these functions get called every time the status of the tracker changes. 105 106This function is passed two 'ProgressStatus' records: the first 107reflects the status prior to the update, and the second reflects 108the status after the update. 109 110Please note that the owning 'Progress' object will be locked while the 111callback is running, so the callback will not be able to make changes to it. -} 112type ProgressCallback = ProgressStatus -> ProgressStatus -> IO () 113 114{- | The main progress status record. -} 115data ProgressStatus = 116 ProgressStatus {completedUnits :: Integer, 117 totalUnits :: Integer, 118 startTime :: Integer, 119 trackerName :: String, -- ^ An identifying string 120 timeSource :: ProgressTimeSource 121 } 122 123data ProgressRecord = 124 ProgressRecord {parents :: [Progress], 125 callbacks :: [ProgressCallback], 126 status :: ProgressStatus} 127 128{- | The main Progress object. -} 129newtype Progress = Progress (MVar ProgressRecord) 130 131class ProgressStatuses a b where 132 {- | Lets you examine the 'ProgressStatus' that is contained 133 within a 'Progress' object. You can simply pass 134 a 'Progress' object and a function to 'withStatus', and 135 'withStatus' will lock the 'Progress' object (blocking any 136 modifications while you are reading it), then pass the object 137 to your function. If you happen to already have a 'ProgressStatus' 138 object, withStatus will also accept it and simply pass it unmodified 139 to the function. -} 140 withStatus :: a -> (ProgressStatus -> b) -> b 141 142class ProgressRecords a b where 143 withRecord :: a -> (ProgressRecord -> b) -> b 144 145{- 146instance ProgressStatuses ProgressRecord b where 147 withStatus x func = func (status x) 148instance ProgressRecords ProgressRecord b where 149 withRecord x func = func x 150-} 151 152instance ProgressStatuses Progress (IO b) where 153 withStatus (Progress x) func = withMVar x (\y -> func (status y)) 154instance ProgressRecords Progress (IO b) where 155 withRecord (Progress x) func = withMVar x func 156 157instance ProgressStatuses ProgressStatus b where 158 withStatus x func = func x 159 160---------------------------------------------------------------------- 161-- Creation 162---------------------------------------------------------------------- 163 164{- | Create a new 'Progress' object with the given name and number 165of total units initialized as given. The start time will be initialized 166with the current time at the present moment according to the system clock. 167The units completed will be set to 0, the time source will be set to the 168system clock, and the parents and callbacks will be empty. 169 170If you need more control, see 'newProgress\''. 171 172Example: 173 174> prog <- newProgress "mytracker" 1024 175 176-} 177newProgress :: String -- ^ Name of this tracker 178 -> Integer -- ^ Total units expected 179 -> IO Progress 180newProgress name total = 181 do t <- defaultTimeSource 182 newProgress' (ProgressStatus {completedUnits = 0, totalUnits = total, 183 startTime = t, trackerName = name, 184 timeSource = defaultTimeSource}) 185 [] 186 187{- | Create a new 'Progress' object initialized with the given status and 188callbacks. 189No adjustment to the 'startTime' will be made. If you 190want to use the system clock, you can initialize 'startTime' with 191the return value of 'defaultTimeSource' and also pass 'defaultTimeSource' 192as the timing source. -} 193newProgress' :: ProgressStatus 194 -> [ProgressCallback] -> IO Progress 195newProgress' news newcb = 196 do r <- newMVar $ ProgressRecord {parents = [], 197 callbacks = newcb, status = news} 198 return (Progress r) 199 200{- | Adds an new callback to an existing 'Progress'. The callback will be 201called whenever the object's status is updated, except by the call to finishP. 202 203Please note that the Progress object will be locked while the callback is 204running, so the callback will not be able to make any modifications to it. 205-} 206addCallback :: Progress -> ProgressCallback -> IO () 207addCallback (Progress mpo) cb = modifyMVar_ mpo $ \po -> 208 return $ po {callbacks = cb : callbacks po} 209 210{- | Adds a new parent to an existing 'Progress'. The parent 211will automatically have its completed and total counters incremented 212by the value of those counters in the existing 'Progress'. -} 213addParent :: Progress -- ^ The child object 214 -> Progress -- ^ The parent to add to this child 215 -> IO () 216addParent (Progress mcpo) ppo = modifyMVar_ mcpo $ \cpo -> 217 do incrP' ppo (completedUnits . status $ cpo) 218 incrTotal ppo (totalUnits . status $ cpo) 219 return $ cpo {parents = ppo : parents cpo} 220 221{- | Call this when you are finished with the object. It is especially 222important to do this when parent objects are involved. 223 224This will simply set the totalUnits to the current completedUnits count, 225but will not call the callbacks. It will additionally propogate 226any adjustment in totalUnits to the parents, whose callbacks /will/ be 227called. 228 229This ensures that the total expected counts on the parent are always correct. 230Without doing this, if, say, a transfer ended earlier than expected, ETA 231values on the parent would be off since it would be expecting more data than 232actually arrived. -} 233finishP :: Progress -> IO () 234finishP (Progress mp) = 235 modifyMVar_ mp modfunc 236 where modfunc :: ProgressRecord -> IO ProgressRecord 237 modfunc oldpr = 238 do let adjustment = (completedUnits . status $ oldpr) 239 - (totalUnits . status $ oldpr) 240 callParents oldpr (\x -> incrTotal x adjustment) 241 return $ oldpr {status = (status oldpr) 242 {totalUnits = completedUnits . status $ oldpr}} 243 244---------------------------------------------------------------------- 245-- Updating 246---------------------------------------------------------------------- 247{- | Increment the completed unit count in the 'Progress' object 248by the amount given. If the value as given exceeds the total, then 249the total will also be raised to match this value so that the 250completed count never exceeds the total. 251 252You can decrease the completed unit count by supplying a negative number 253here. -} 254incrP :: Progress -> Integer -> IO () 255incrP po count = modStatus po statusfunc 256 where statusfunc s = 257 s {completedUnits = newcu s, 258 totalUnits = if newcu s > totalUnits s 259 then newcu s 260 else totalUnits s} 261 newcu s = completedUnits s + count 262 263{- | Like 'incrP', but never modify the total. -} 264incrP' :: Progress -> Integer -> IO () 265incrP' po count = 266 modStatus po (\s -> s {completedUnits = completedUnits s + count}) 267 268{- | Set the completed unit count in the 'Progress' object to the specified 269value. Unlike 'incrP', this function sets the count to a specific value, 270rather than adding to the existing value. If this value exceeds the total, 271then the total will also be raised to match this value so that the completed 272count never exceeds teh total. -} 273setP :: Progress -> Integer -> IO () 274setP po count = modStatus po statusfunc 275 where statusfunc s = 276 s {completedUnits = count, 277 totalUnits = if count > totalUnits s 278 then count 279 else totalUnits s} 280 281{- | Like 'setP', but never modify the total. -} 282setP' :: Progress -> Integer -> IO () 283setP' po count = modStatus po (\s -> s {completedUnits = count}) 284 285{- | Increment the total unit count in the 'Progress' object by the amount 286given. This would rarely be needed, but could be needed in some special cases 287when the total number of units is not known in advance. -} 288incrTotal :: Progress -> Integer -> IO () 289incrTotal po count = 290 modStatus po (\s -> s {totalUnits = totalUnits s + count}) 291 292{- | Set the total unit count in the 'Progress' object to the specified 293value. Like 'incrTotal', this would rarely be needed. -} 294setTotal :: Progress -> Integer -> IO () 295setTotal po count = 296 modStatus po (\s -> s {totalUnits = count}) 297 298---------------------------------------------------------------------- 299-- Reading and Processing 300---------------------------------------------------------------------- 301 302{- | Returns the speed in units processed per time unit. (If you are 303using the default time source, this would be units processed per second). 304This obtains the current speed solely from analyzing the 'Progress' object. 305 306If no time has elapsed yet, returns 0. 307 308You can use this against either a 'Progress' object or a 'ProgressStatus' 309object. This is in the IO monad because the speed is based on the current 310time. 311 312Example: 313 314> getSpeed progressobj >>= print 315 316Don't let the type of this function confuse you. It is a fancy way of saying 317that it can take either a 'Progress' or a 'ProgressStatus' object, and returns 318a number that is valid as any Fractional type, such as a Double, Float, or 319Rational. -} 320getSpeed :: (ProgressStatuses a (IO b), Fractional b) => a -> IO b 321getSpeed po = withStatus po $ \status -> 322 do t <- timeSource status 323 let elapsed = t - (startTime status) 324 return $ if elapsed == 0 325 then fromRational 0 326 else fromRational ((completedUnits status) % elapsed) 327 328{- | Returns the estimated time remaining, in standard time units. 329 330Returns 0 whenever 'getSpeed' would return 0. 331 332See the comments under 'getSpeed' for information about this function's type 333and result. -} 334getETR :: (ProgressStatuses a (IO Integer), 335 ProgressStatuses a (IO Rational)) => a -> IO Integer 336getETR po = 337 do speed <- ((getSpeed po)::IO Rational) 338 if speed == 0 339 then return 0 340 else 341 -- FIXME: potential for a race condition here, but it should 342 -- be negligible 343 withStatus po $ \status -> 344 do let remaining = totalUnits status - completedUnits status 345 return $ round $ (toRational remaining) / speed 346 347{- | Returns the estimated system clock time of completion, in standard 348time units. Returns the current time whenever 'getETR' would return 0. 349 350See the comments under 'getSpeed' for information about this function's type 351and result. -} 352getETA :: (ProgressStatuses a (IO Integer), 353 ProgressStatuses a (IO Rational)) => a -> IO Integer 354getETA po = 355 do etr <- getETR po 356 -- FIXME: similar race potential here 357 withStatus po $ \status -> 358 do timenow <- timeSource status 359 return $ timenow + etr 360 361---------------------------------------------------------------------- 362-- Utilities 363---------------------------------------------------------------------- 364{- | The default time source for the system. This is defined as: 365 366>getClockTime >>= (return . clockTimeToEpoch) 367-} 368defaultTimeSource :: ProgressTimeSource 369defaultTimeSource = getClockTime >>= (return . clockTimeToEpoch) 370 371now :: ProgressRecords a ProgressTimeSource => a -> ProgressTimeSource 372now x = withRecord x (timeSource . status) 373 374modStatus :: Progress -> (ProgressStatus -> ProgressStatus) -> IO () 375-- FIXME/TODO: handle parents 376modStatus (Progress mp) func = 377 modifyMVar_ mp modfunc 378 where modfunc :: ProgressRecord -> IO ProgressRecord 379 modfunc oldpr = 380 do let newpr = oldpr {status = func (status oldpr)} 381 mapM_ (\x -> x (status oldpr) (status newpr)) 382 (callbacks oldpr) 383 384 -- Kick it up to the parents. 385 case (completedUnits . status $ newpr) - 386 (completedUnits . status $ oldpr) of 387 0 -> return () 388 x -> callParents newpr (\y -> incrP' y x) 389 case (totalUnits . status $ newpr) - 390 (totalUnits . status $ oldpr) of 391 0 -> return () 392 x -> callParents newpr (\y -> incrTotal y x) 393 return newpr 394 395callParents :: ProgressRecord -> (Progress -> IO ()) -> IO () 396callParents pr func = mapM_ func (parents pr) 397 398