From 350f7eca60f021ebe4b5b567822b76379ef6be92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Mon, 19 Jun 2023 08:58:01 +0200 Subject: [PATCH] Factor out with-mbase-progress. --- src/export-web-static.scm | 4 +++- src/export-wiki-compat.scm | 19 +++---------------- src/mbase.scm | 28 ++++++++++++++++++++++++++++ 3 files changed, 34 insertions(+), 17 deletions(-) diff --git a/src/export-web-static.scm b/src/export-web-static.scm index ca799a3..c13572f 100644 --- a/src/export-web-static.scm +++ b/src/export-web-static.scm @@ -34,7 +34,8 @@ (import scheme (chicken base) (chicken format) - brmember) + brmember + util-dir) (define (print-html-member mr) (print "") @@ -52,6 +53,7 @@ #f)) (define (gen-html-members mb dir) + (ensure-directory dir) #f) ) diff --git a/src/export-wiki-compat.scm b/src/export-wiki-compat.scm index 0cd5924..4f7a690 100644 --- a/src/export-wiki-compat.scm +++ b/src/export-wiki-compat.scm @@ -81,21 +81,8 @@ ;; Generates all member files in given directory (define (gen-web-static mb dir) (ensure-directory dir) - (let* ((members-list (find-members-by-predicate mb brmember-existing?)) - (mlen0 (length members-list)) - (mlen (if (> mlen0 0) - mlen0 - 1))) - (with-progress% - #t dir - (let loop ((mb members-list) - (i 0)) - (if (not (null? mb)) - (let () - (progress%-advance (/ i mlen)) - (gen-web-static-member (car mb) dir) - (loop (cdr mb) - (add1 i)))) - (progress%-advance 1))))) + (with-mbase-progress% + mb dir mr + (gen-web-static-member mr dir))) ) diff --git a/src/mbase.scm b/src/mbase.scm index c9b7b34..1303dbe 100644 --- a/src/mbase.scm +++ b/src/mbase.scm @@ -58,6 +58,9 @@ mbase-active-emails mbase-merge-mailman + + do-with-mbase-progress% + with-mbase-progress% ) (import scheme @@ -288,4 +291,29 @@ mb emails))) + ;; Iteration with progress over all members + (define (do-with-mbase-progress% mb name proc) + (let* ((members-list (find-members-by-predicate mb brmember-existing?)) + (mlen0 (length members-list)) + (mlen (if (> mlen0 0) + mlen0 + 1))) + (with-progress% + #t name + (let loop ((mb members-list) + (i 0)) + (if (not (null? mb)) + (let () + (progress%-advance (/ i mlen)) + (proc (car mb)) + (loop (cdr mb) + (add1 i)))) + (progress%-advance 1))))) + + ;; Simple syntax wrapper + (define-syntax with-mbase-progress% + (syntax-rules () + ((_ mb name mr body ...) + (do-with-mbase-progress% mb name (lambda (mr) body ...))))) + )