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