From 6a597d71c8a74f8cd239b4a0be4cb3fdab9667cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 7 Apr 2023 23:36:12 +0200 Subject: [PATCH] Show destroyed only when requested in fees. --- src/bbstool.scm | 5 +- src/members-print.scm | 206 ++++++++++++++++++++++-------------------- 2 files changed, 113 insertions(+), 98 deletions(-) diff --git a/src/bbstool.scm b/src/bbstool.scm index c3368fc..7820116 100644 --- a/src/bbstool.scm +++ b/src/bbstool.scm @@ -69,6 +69,7 @@ CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. (define -normal-month- (make-parameter #t)) (define -jendasap-checked- (make-parameter "checked.ntlm")) (define -ml-all- (make-parameter #f)) +(define -show-destroyed- (make-parameter #f)) ;; Arguments parsing (command-line @@ -98,6 +99,8 @@ CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. (-jendasap-checked- file)) (-ml-all () "Load all mailman lists" (-ml-all- #t)) + (-destroyed () "Show destroyed members in -fees" + (-show-destroyed- #t)) "" "Query options:" (-mi (id) "Specify member by id" (-member-id- (string->number id))) @@ -262,7 +265,7 @@ CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. (print "No problems found.")))) ((fees) (newline) - (print-members-fees-table MB)) + (print-members-fees-table MB (-show-destroyed-))) ((repl) (repl)) ((genweb) diff --git a/src/members-print.scm b/src/members-print.scm index f89efc1..24d87e0 100644 --- a/src/members-print.scm +++ b/src/members-print.scm @@ -337,103 +337,115 @@ ")")))) ;; Prints summary table of all fees and credits for all members - (define (print-members-fees-table MB) - (let ((balances (map member-balance (members-base-members MB))) - (members ;; Pass 1 - (map - (lambda (mr) - (let* ((balance (member-balance mr)) - (fees (dict-ref balance 'fees)) - (credit (dict-ref balance 'credit)) - (payment (dict-ref balance 'payment)) - (total (- (+ credit payment) fees))) - (list (member-nick mr) - (if (member-suspended? mr) - 'suspended - (if (member-student? mr) - 'student - (if (member-destroyed? mr) - 'destroyed - 'active))) - fees - credit - payment - total - ))) - (sort (members-base-members MB) memberstring - (cons - (list (ansi-string #:bgblue #:brightyellow #:bold "Member") - (ansi-string #:bgblue #:brightyellow #:bold "Status") - (ansi-string #:bgblue #:brightyellow #:bold "Fees") - (ansi-string #:bgblue #:brightyellow #:bold "Credit") - (ansi-string #:bgblue #:brightyellow #:bold "Payments") - (ansi-string #:bgblue #:brightyellow #:bold "Balance")) - (append - (map ;; Pass 2 - (lambda (member) - (let ((total (list-ref member 5))) - (list (list-ref member 0) - (list-ref member 1) - (sprintf "\t~A" (list-ref member 2)) - (sprintf "\t~A" (list-ref member 3)) - (sprintf "\t~A" (list-ref member 4)) - (sprintf "\t~A~A~A" - (if (< total -500) - a:error - (if (< total 0) - a:warning - a:success)) - (exact->inexact total) - a:default) - ))) - members) - (let* ((fees (foldl + 0 (map (lambda (b) (dict-ref b 'fees)) balances))) - (credit (foldl + 0 (map (lambda (b) (dict-ref b 'credit)) balances))) - (payment (foldl + 0 (map (lambda (b) (dict-ref b 'payment)) balances))) - (total (- (+ credit payment) fees))) - (list (list (ansi-string #:bold "Total") - "" - (ansi-string "\t" #:bold (sprintf "~A" fees)) - (ansi-string "\t" #:bold (sprintf "~A" credit)) - (ansi-string "\t" #:bold (sprintf "~A" payment)) - (ansi-string "\t" #:bold - (sprintf "~A~A" - (if (< total 0) - a:error - a:success) - total)) - ))))) - #:col-border #t #:row0-border #t #:ansi #t)) - (print "Credit: " - (foldl + 0 - (map (lambda (member) - (list-ref member 5)) - members))) - (print "Advance: " - (foldl + 0 - (map (lambda (member) - (max 0 (list-ref member 5))) - members))) - (print "Debt: " - (foldl + 0 - (map (lambda (member) - (min 0 (list-ref member 5))) - members))) - (let* ((ns (foldl (lambda (acc member) - (cons (+ (car acc) (if (eq? 'student (cadr member)) 1 0)) - (+ (cdr acc) (if (eq? 'active (cadr member)) 1 0)))) - (cons 0 0) - members)) - (students (car ns)) - (full (cdr ns))) - (print "Expected income: " - (+ (* (lookup-member-fee 'normal) full) - (* (lookup-member-fee 'student) students)) - " (" full " full members + " students " students)")) - ) - ) + (define (print-members-fees-table MB . ds) + (let ((destroyed? (if (null? ds) + #f + (car ds)))) + (let* ((members ;; Pass 1 + (map + (lambda (mr) + (let* ((balance (member-balance mr)) + (fees (dict-ref balance 'fees)) + (credit (dict-ref balance 'credit)) + (payment (dict-ref balance 'payment)) + (total (- (+ credit payment) fees))) + (list (member-nick mr) + (if (member-suspended? mr) + 'suspended + (if (member-student? mr) + 'student + (if (member-destroyed? mr) + 'destroyed + 'active))) + fees + credit + payment + total + balance + ))) + (sort + (if destroyed? + (members-base-members MB) + (filter (lambda (mr) + (not (member-destroyed? mr))) + (members-base-members MB))) + memberstring + (cons + (list (ansi-string #:bgblue #:brightyellow #:bold "Member") + (ansi-string #:bgblue #:brightyellow #:bold "Status") + (ansi-string #:bgblue #:brightyellow #:bold "Fees") + (ansi-string #:bgblue #:brightyellow #:bold "Credit") + (ansi-string #:bgblue #:brightyellow #:bold "Payments") + (ansi-string #:bgblue #:brightyellow #:bold "Balance")) + (append + (map ;; Pass 2 + (lambda (member) + (let ((total (list-ref member 5))) + (list (list-ref member 0) + (list-ref member 1) + (sprintf "\t~A" (list-ref member 2)) + (sprintf "\t~A" (list-ref member 3)) + (sprintf "\t~A" (list-ref member 4)) + (sprintf "\t~A~A~A" + (if (< total -500) + a:error + (if (< total 0) + a:warning + a:success)) + (exact->inexact total) + a:default) + ))) + members) + (let* ((fees (foldl + 0 (map (lambda (b) (dict-ref b 'fees)) balances))) + (credit (foldl + 0 (map (lambda (b) (dict-ref b 'credit)) balances))) + (payment (foldl + 0 (map (lambda (b) (dict-ref b 'payment)) balances))) + (total (- (+ credit payment) fees))) + (list (list (ansi-string #:bold "Total") + "" + (ansi-string "\t" #:bold (sprintf "~A" fees)) + (ansi-string "\t" #:bold (sprintf "~A" credit)) + (ansi-string "\t" #:bold (sprintf "~A" payment)) + (ansi-string "\t" #:bold + (sprintf "~A~A" + (if (< total 0) + a:error + a:success) + total)) + ))))) + #:col-border #t #:row0-border #t #:ansi #t)) + (print "Credit: " + (foldl + 0 + (map (lambda (member) + (list-ref member 5)) + members))) + (print "Advance: " + (foldl + 0 + (map (lambda (member) + (max 0 (list-ref member 5))) + members))) + (print "Debt: " + (foldl + 0 + (map (lambda (member) + (min 0 (list-ref member 5))) + members))) + (let* ((ns (foldl (lambda (acc member) + (cons (+ (car acc) (if (eq? 'student (cadr member)) 1 0)) + (+ (cdr acc) (if (eq? 'active (cadr member)) 1 0)))) + (cons 0 0) + members)) + (students (car ns)) + (full (cdr ns))) + (print "Expected income: " + (+ (* (lookup-member-fee 'normal) full) + (* (lookup-member-fee 'student) students)) + " (" full " full members + " students " students)")) + ) + )) ;; Prints all transactions which the members base considers unpaired. (define (print-unpaired-table mb)