Coverage report: /home/ellis/comp/core/lib/cli/progress.lisp

Kind	Covered	All	%
expression	18	218	8.3
branch	1	22	4.5

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; lib/cli/progress.lisp --- Progress Bars

2

3

;; from https://github.com/sirherrbatka/cl-progress-bar

4

5

;;; Code:

6

(in-package :cli/progress)

7

8

(defclass progress-bar ()

9

((start-time

10

:initarg :start-time

11

:accessor start-time)

12

(end-time

13

:initarg :end-time

14

:accessor end-time)

15

(progress-character

16

:initarg :progress-character

17

:accessor progress-character)

18

(character-count

19

:initarg :character-count

20

:accessor character-count

21

:documentation "How many characters wide is the progress bar?")

22

(characters-so-far

23

:initarg :characters-so-far

24

:accessor characters-so-far)

25

(update-interval

26

:initarg :update-interval

27

:accessor update-interval

28

:documentation "Update the progress bar display after this many

29

internal-time units.")

30

(last-update-time

31

:initarg :last-update-time

32

:accessor last-update-time

33

:documentation "The display was last updated at this time.")

34

(total

35

:initarg :total

36

:accessor total

37

:documentation "The total number of units tracked by this progress bar.")

38

(progress

39

:initarg :progress

40

:accessor progress

41

:documentation "How far in the progress are we?")

42

(mutex

43

:initarg :mutex

44

:reader progress-mutex

45

:documentation "Just a mutex, allows progress bar to be thread safe.")

46

(pending

47

:initarg :pending

48

:accessor pending

49

:documentation "How many raw units should be tracked in the next

50

display update?"))

51

(:default-initargs

52

:mutex (sb-thread:make-mutex)

53

:progress-character #\=

54

:character-count 50

55

:characters-so-far 0

56

:update-interval (floor internal-time-units-per-second 4)

57

:last-update-time 0

58

:total 0

59

:progress 0

60

:pending 0))

61

62

(defgeneric start-progress-display (progress-bar))

63

(defgeneric update-progress (progress-bar unit-count))

64

(defgeneric update-progress-display (progress-bar))

65

(defgeneric finish-progress-display (progress-bar))

66

(defgeneric elapsed-time (progress-bar))

67

(defgeneric units-per-second (progress-bar))

68

69

(defmethod start-progress-display (progress-bar)

70

(setf (last-update-time progress-bar) (get-internal-real-time))

71

(setf (start-time progress-bar) (get-internal-real-time))

72

(fresh-line)

73

(finish-output))

74

75

(defmethod update-progress-display (progress-bar)

76

(incf (progress progress-bar) (pending progress-bar))

77

(setf (pending progress-bar) 0)

78

(setf (last-update-time progress-bar) (get-internal-real-time))

79

(unless (zerop (progress progress-bar))

80

(let* ((showable (floor (character-count progress-bar)

81

(/ (total progress-bar) (progress progress-bar))))

82

(needed (- showable (characters-so-far progress-bar))))

83

(setf (characters-so-far progress-bar) showable)

84

(dotimes (i needed)

85

(write-char (progress-character progress-bar)))

86

(finish-output))))

87

88

(defmethod update-progress (progress-bar unit-count)

89

(incf (pending progress-bar) unit-count)

90

(let ((now (get-internal-real-time)))

91

(when (< (update-interval progress-bar)

92

(- now (last-update-time progress-bar)))

93

(update-progress-display progress-bar))))

94

95

(defconstant +seconds-in-one-hour+ 3600)

96

(defconstant +seconds-in-one-minute+ 60)

97

98

(defun time-in-seconds-minutes-hours (in-seconds)

99

(unless (zerop in-seconds)

100

(format t "Finished in")

101

(when (>= in-seconds +seconds-in-one-hour+)

102

(let* ((hours (floor (/ in-seconds +seconds-in-one-hour+))))

103

(decf in-seconds (* hours +seconds-in-one-hour+))

104

(format t " ~a hour~p" hours hours)))

105

(when (>= in-seconds +seconds-in-one-minute+)

106

(let* ((minutes (floor (/ in-seconds +seconds-in-one-minute+))))

107

(decf in-seconds (* minutes +seconds-in-one-minute+))

108

(format t " ~a minute~p" minutes minutes)))

109

(unless (zerop in-seconds) (format t " ~$ seconds" in-seconds)))

110

(terpri))

111

112

(defmethod finish-progress-display (progress-bar)

113

(update-progress-display progress-bar)

114

(setf (end-time progress-bar) (get-internal-real-time))

115

(terpri)

116

(time-in-seconds-minutes-hours (elapsed-time progress-bar))

117

(finish-output)

118

(unless (= (progress progress-bar) (total progress-bar))

119

(warn "Expected TOTAL is ~a but progress at the moment of finishing is ~a"

120

(total progress-bar)

121

(progress progress-bar))))

122

123

(defmethod elapsed-time (progress-bar)

124

(/ (- (end-time progress-bar) (start-time progress-bar))

125

internal-time-units-per-second))

126

127

(defmethod units-per-second (progress-bar)

128

(if (plusp (elapsed-time progress-bar))

129

(/ (total progress-bar) (elapsed-time progress-bar))

130

0))

131

132

(defparameter *uncertain-progress-chars* "?")

133

134

(defclass uncertain-size-progress-bar (progress-bar)

135

((progress-char-index

136

:initarg :progress-char-index

137

:accessor progress-char-index)

138

(units-per-char

139

:initarg :units-per-char

140

:accessor units-per-char))

141

(:default-initargs

142

:total nil

143

:progress-char-index 1

144

:units-per-char (floor (expt 1024 2) 50)))

145

146

(defmethod update-progress :after ((progress-bar uncertain-size-progress-bar)

147

unit-count)

148

(incf (total progress-bar) unit-count))

149

150

(defmethod progress-character ((progress-bar uncertain-size-progress-bar))

151

(let ((index (progress-char-index progress-bar)))

152

(prog1

153

(char *uncertain-progress-chars* index)

154

(setf (progress-char-index progress-bar)

155

(mod (1+ index) (length *uncertain-progress-chars*))))))

156

157

(defmethod update-progress-display ((progress-bar uncertain-size-progress-bar))

158

(setf (last-update-time progress-bar) (get-internal-real-time))

159

(multiple-value-bind (chars pend)

160

(floor (pending progress-bar) (units-per-char progress-bar))

161

(setf (pending progress-bar) pend)

162

(dotimes (i chars)

163

(write-char (progress-character progress-bar))

164

(incf (characters-so-far progress-bar))

165

(when (<= (character-count progress-bar)

166

(characters-so-far progress-bar))

167

(terpri)

168

(setf (characters-so-far progress-bar) 0)

169

(finish-output)))

170

(finish-output)))

171

172

(defvar *progress-bar* nil)

173

(defparameter *progress-bar-enabled* nil)

174

175

(declaim (inline update))

176

(defun update! (unit-count &optional (progress-bar *progress-bar*))

177

(check-type unit-count (integer 1 *))

178

(check-type progress-bar (or null progress-bar))

179

(unless (null progress-bar)

180

(sb-thread:with-mutex ((progress-mutex progress-bar))

181

(update-progress progress-bar unit-count))))

182

183

(defun make-progress-bar (total)

184

(check-type total (or null (integer 0 *)))

185

(if (or (not total) (zerop total))

186

(make-instance 'uncertain-size-progress-bar)

187

(make-instance 'progress-bar

188

:total total)))

189

190

(defmacro with-progress-bar ((steps-count description &rest desc-args) &body body)

191

(let ((!old-bar (gensym)))

192

`(let* ((,!old-bar *progress-bar*)

193

(*progress-bar* (or ,!old-bar

194

(when *progress-bar-enabled*

195

(make-progress-bar ,steps-count)))))

196

(unless (eq ,!old-bar *progress-bar*)

197

(fresh-line)

198

(format t ,description ,@desc-args)

199

(start-progress-display *progress-bar*))

200

(prog1 (progn ,@body)

201

(unless (eq ,!old-bar *progress-bar*)

202

(finish-progress-display *progress-bar*))))))

203

204

(defmacro with-progress-maybe (enabled (steps-count description &rest desc-args) &body body)

205

(declare (ignorable steps-count description desc-args))

206

`(if ,enabled

207

(with-progress-bar (,steps-count ,description ,@desc-args) ,@body)

208

(progn ,@body)))