brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Factor out with-mbase-progress.

Browse source
This commit is contained in:
Dominik Pantůček 2023-06-19 08:58:01 +02:00
parent a56605fa3f
commit 350f7eca60
3 changed files with 34 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/export-web-static.scm
View file

@ -34,7 +34,8 @@
(import scheme (import scheme
(chicken base) (chicken base)
(chicken format) (chicken format)
brmember) brmember
util-dir)
(define (print-html-member mr) (define (print-html-member mr)
(print "<html>") (print "<html>")
@ -52,6 +53,7 @@
#f)) #f))
(define (gen-html-members mb dir) (define (gen-html-members mb dir)
(ensure-directory dir)
#f) #f)
) )

19
src/export-wiki-compat.scm
View file

@ -81,21 +81,8 @@
;; Generates all member files in given directory ;; Generates all member files in given directory
(define (gen-web-static mb dir) (define (gen-web-static mb dir)
(ensure-directory dir) (ensure-directory dir)
(let* ((members-list (find-members-by-predicate mb brmember-existing?)) (with-mbase-progress%
(mlen0 (length members-list)) mb dir mr
(mlen (if (> mlen0 0) (gen-web-static-member mr dir)))
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)))))
) )

28
src/mbase.scm
View file

@ -58,6 +58,9 @@
mbase-active-emails mbase-active-emails
mbase-merge-mailman mbase-merge-mailman
do-with-mbase-progress%
with-mbase-progress%
) )
(import scheme (import scheme
@ -288,4 +291,29 @@
mb mb
emails))) 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 ...)))))
) )