From 08ad923f6a11745eb847630160ddc9233a80ad4a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?=
 <dominik.pantucek@trustica.cz>
Date: Mon, 20 Mar 2023 16:16:40 +0100
Subject: [PATCH] Use progress-advance.

---
 Makefile         |  3 ++-
 members-base.scm | 51 ++++++++++++++++++++++++------------------------
 progress.scm     | 27 ++++++++++++++-----------
 3 files changed, 43 insertions(+), 38 deletions(-)

diff --git a/Makefile b/Makefile
index 13c356d..8ee642c 100644
--- a/Makefile
+++ b/Makefile
@@ -130,7 +130,8 @@ command-line.import.scm: $(COMMAND-LINE-SOURCES)
 MEMBERS-BASE-SOURCES=members-base.scm testing.import.scm		\
 	utils.import.scm dictionary.import.scm member-file.import.scm	\
 	primes.import.scm member-record.import.scm ansi.import.scm	\
-	period.import.scm month.import.scm configuration.import.scm
+	period.import.scm month.import.scm configuration.import.scm	\
+	progress.import.scm
 
 members-base.so: members-base.o
 members-base.o: members-base.import.scm
diff --git a/members-base.scm b/members-base.scm
index 3d516e8..a77dce8 100644
--- a/members-base.scm
+++ b/members-base.scm
@@ -58,8 +58,9 @@
 	 ansi
 	 period
 	 month
-	 configuration)
-
+	 configuration
+	 progress)
+ 
  ;; Gets all files and symbolic links from given directory. The
  ;; symbolic links are represented by cons cells with car being the
  ;; name and cdr the link target.
@@ -172,30 +173,28 @@
  (define (load-members dn . opts)
    (let ((progress? (and (not (null? opts))
 			 (car opts))))
-     (when progress?
-       (display "Loading members "))
-     (let* ((fss (files-dictionary-filter-4digit-symbols
-		  (files+symlinks->files-dictionary
-		   (get-files+symlinks dn))))
-	    (mb0 (dict-map
-		  (lambda (symfn symlinks)
-		    (when progress?
-		      (display "."))
-		    (members-base-load-member dn
-					      symfn
-					      symlinks))
-		  fss))
-	    (mb1 (dict-reduce (make-dict)
-			      (lambda (acc symfn mr)
-				(dict-set acc (dict-ref mr 'id) mr))
-			      mb0))
-	    (mb (dict-reduce '()
-			     (lambda (acc id mr)
-			       (cons mr acc))
-			     mb1)))
-       (when progress?
-	 (print " ok."))
-       mb)))
+     (with-progress
+      progress? "Loading-members " " ok."
+      (let* ((fss (files-dictionary-filter-4digit-symbols
+		   (files+symlinks->files-dictionary
+		    (get-files+symlinks dn))))
+	     (mb0 (dict-map
+		   (lambda (symfn symlinks)
+		     (when progress?
+		       (progress-advance "."))
+		     (members-base-load-member dn
+					       symfn
+					       symlinks))
+		   fss))
+	     (mb1 (dict-reduce (make-dict)
+			       (lambda (acc symfn mr)
+				 (dict-set acc (dict-ref mr 'id) mr))
+			       mb0))
+	     (mb (dict-reduce '()
+			      (lambda (acc id mr)
+				(cons mr acc))
+			      mb1)))
+	mb))))
 
  ;; Gets member based by generic predicate
  (define (find-member-by-predicate mb pred)
diff --git a/progress.scm b/progress.scm
index 5887437..d74b28e 100644
--- a/progress.scm
+++ b/progress.scm
@@ -23,7 +23,7 @@
 ;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 ;;
 
-(declare (unit configuration))
+(declare (unit progress))
 
 (module
  progress
@@ -43,26 +43,31 @@
 
  ;; Prints current progress.
  (define (print-current-progress . args)
-   (display (sprintf "\r\x1b[K~A" (*current-progress*))))
+   (let ((cp (*current-progress*)))
+     (when cp
+       (display (sprintf "\r\x1b[K~A" cp)))))
 
  ;; Adds something to current progress and refreshes the display.
  (define (progress-advance str)
-   (*current-progress* (string-append (*current-progress*) (sprintf "~A" str)))
-   (print-current-progress))
+   (when (*current-progress*)
+     (*current-progress* (string-append (*current-progress*) (sprintf "~A" str)))
+     (print-current-progress)))
 
  ;; Runs given procedure within progress environment
- (define (run-with-progress pre-msg post-msg thunk)
-   (parameterize ((*current-progress* pre-msg))
+ (define (run-with-progress echo? pre-msg post-msg thunk)
+   (parameterize ((*current-progress* (if echo? pre-msg #f)))
      (print-current-progress)
-     (thunk)
-     (print-current-progress)
-     (print post-msg)))
+     (let ((result (thunk)))
+       (print-current-progress)
+       (when echo?
+	 (print post-msg))
+       result)))
 
  ;; Friendly syntax wrapper.
  (define-syntax with-progress
    (syntax-rules ()
-     ((_ pre post body ...)
-      (run-with-progress pre post (lambda () body ...)))))
+     ((_ echo? pre post body ...)
+      (run-with-progress echo? pre post (lambda () body ...)))))
 
  ;; If the program uses progress module, disable buffering
  (set-buffering-mode! (current-output-port) #:none)