Move sources to separate directory.

src/members-print.scm

@@ -0,0 +1,374 @@
+;;
+;; members-print.scm
+;;
+;; Procedures working with complete member record (as loaded by the
+;; members-base).
+;;
+;; ISC License
+;;
+;; Copyright 2023 Brmlab, z.s.
+;; Dominik Pantůček <dominik.pantucek@trustica.cz>
+;;
+;; Permission to use, copy, modify, and/or distribute this software
+;; for any purpose with or without fee is hereby granted, provided
+;; that the above copyright notice and this permission notice appear
+;; in all copies.
+;; 
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
+;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(declare (unit members-print))
+
+(module
+ members-print
+ (
+  print-member-info
+  print-member-table
+  print-member-source
+  print-members-base-info
+  print-members-base-table
+  print-members-base-stats
+  print-members-ids-stats
+  print-members-fees-table
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken string)
+	 (chicken sort)
+	 (chicken format)
+	 dictionary
+	 member-record
+	 month
+	 utils
+	 table
+	 listing
+	 ansi
+	 period
+	 primes
+	 members-base
+	 configuration
+	 bank-account
+	 member-fees)
+
+ ;; Prints human-readable information
+ (define (print-member-info mr)
+   (let* ((id (dict-ref mr 'id))
+	  (aliases (dict-ref mr 'symlinks))
+	  (info (dict-ref mr 'info))
+	  (sinfo (sort info
+		       (lambda (a b)
+			 (string<?
+			  (symbol->string (car a))
+			  (symbol->string (car b)))))))
+     (print "User " id " alias(es): "
+	    (string-intersperse
+	     (map symbol->string aliases)
+	     ", "))
+     (when (member-suspended? mr)
+       (print "  Suspended for " (member-suspended-months mr) " months."))
+     (newline)
+     (let loop ((sinfo sinfo))
+       (when (not (null? sinfo))
+	 (let* ((kv (car sinfo))
+		(k (car kv))
+		(v (cdr kv)))
+	   (loop (cdr sinfo)))))))
+
+ ;; Returns nicely formatted table
+ (define (member-info->table mr)
+   (let* ((aliases (dict-ref mr 'symlinks))
+	  (mid (member-id mr))
+	  (head (list (if (is-4digit-prime? mid)
+			  (list "ID:" mid)
+			  (list (ansi-string #:red #:bold "ID:")
+				(ansi-string #:red #:bold (number->string mid) " (not prime)")))
+		      (list (sprintf "Alias~A:" (if (> (length aliases) 1) "es" ""))
+			    (string-intersperse (map symbol->string aliases) ", "))
+		      (if (member-suspended? mr)
+			  (list "Suspended for:"
+				(let ((msm (member-suspended-months mr)))
+				  (sprintf "~A month~A" msm
+					   (if (> msm 1) "s" ""))))
+			  #f)))
+	  (info (dict-ref mr 'info))
+	  (sikeys (sort (dict-keys info)
+			(lambda (a b)
+			  (string<?
+			   (symbol->string a)
+			   (symbol->string b)))))
+	  (body (map (lambda (k)
+		       (let ((v (dict-ref info k)))
+			 (case k
+			   ((card desfire credit)
+			    (list k 
+				  (table->string
+				   (map
+				    (lambda (c)
+				      (list (car c) (cdr c)))
+				    v)
+				   #:col-border #t)))
+			   ((suspend student member)
+			    (list k
+				  (table->string
+				   (cons (list "Since" "Until")
+					 (map
+					  (lambda (p)
+					    (list
+					     (string-append (month->string (period-since p)) " "
+							    (or (period-scomment p) ""))
+					     (string-append (month->string (period-before p)) " "
+							    (or (period-bcomment p) ""))))
+					  v))
+				   #:col-border #t)))
+			   (else
+			    (if v
+				(list k v)
+				(list (ansi-string #:red #:bold (symbol->string k))
+				      (ansi-string #:red #:bold "---")))))))
+		     sikeys))
+	  (result (filter identity (append head body))))
+     (table->string result #:table-border #f #:row-border #t #:col-border #t #:ansi #t)))
+
+ ;; Prints nicely formatted table
+ (define (print-member-table mr)
+   (print
+    (table->string
+     (list (list "Basic Information" "Payments" "Membership Status")
+	   (list (member-info->table mr)
+		 (member-payments->table mr)
+		 (member-calendar->table mr))
+	   )
+     #:row0-border #t
+     #:col-border #t)))
+
+ ;; Nicely prints the member source with any errors recorded.
+ (define (print-member-source mr)
+   (let* ((lines (dict-ref mr 'source mr))
+	  (file-name (dict-ref mr 'file-name))
+	  (hls (dict-ref mr 'highlights '())))
+     (print file-name ":")
+     (print-source-listing
+      lines
+      hls
+      #:context -1
+      )))
+
+ ;; Prints nicely printed payments
+ (define (member-payments->table mr)
+   (table->string (cons
+		   (list "Var" "Amount" "Cur" "Date" "TrId")
+		   (map (lambda (tr)
+			  (list (sprintf "\t~A" (bank-transaction-varsym tr))
+				(sprintf "\t~A" (bank-transaction-amount tr))
+				(bank-transaction-currency tr)
+				(bank-transaction-date tr)
+				(bank-transaction-id tr)))
+			(member-payments mr)))
+		  #:row0-border #t
+		  #:col-border #t
+		  ))
+
+ ;; Converts member records to string, optional arguments are format
+ ;; and separator. Format defaults to "~N" and separator to ", ".
+ (define (member-records->string mrs . args)
+   (let ((fmt (if (null? args) "~N" (car args)))
+	 (sep (if (or (null? args)
+		      (null? (cdr args)))
+		  ", "
+		  (cadr args))))
+     (string-intersperse
+      (map (lambda (mr)
+	     (member-format fmt mr))
+	   mrs)
+      sep)))
+
+ ;; Basic information about members-base in human-readable form.
+ (define (print-members-base-info mb)
+   (let ((nicks (list-members-nicks mb))
+	 (ids (list-members-ids mb)))
+     (print "Known members: "
+	    (length nicks))
+     (let* ((bi (members-base-info mb))
+	    (invalid-mrs (dict-ref bi 'invalid))
+	    (active-mrs (dict-ref bi 'active))
+	    (suspended-mrs (dict-ref bi 'suspended))
+	    (destroyed-mrs (dict-ref bi 'destroyed))
+	    (student-mrs (dict-ref bi 'students)))
+       (print a:success "  Active (" (length active-mrs) "): " a:default
+	      (member-records->string (sort active-mrs member<?) "~N~E"))
+       (print a:warning "  Suspended (" (length suspended-mrs) "): " a:default
+	      (member-records->string (sort suspended-mrs member<?) "~N~E"))
+       (print a:warning "  Destroyed (" (length destroyed-mrs) "): " a:default
+	      (member-records->string (sort destroyed-mrs member<?) "~N~E"))
+       (print a:highlight "  Students (" (length student-mrs) "): " a:default
+	      (member-records->string (sort student-mrs member<?)))
+       (let ((suspended2 (filter-members-by-predicate
+			  suspended-mrs
+			  (lambda (mr)
+			    (>= (member-suspended-months mr) 24)))))
+	 (when (not (null? suspended2))
+	   (print (ansi #:magenta) "  Suspended for at least 24 months ("
+		  (length suspended2) "): " a:default
+		  (member-records->string (sort suspended2 member<?) "~N (~S)"))))
+       (when (not (null? invalid-mrs))
+	 (print a:error "  Invalid Id (" (length invalid-mrs) "): "
+		(member-records->string (sort invalid-mrs member<?) "~N (~I)")
+		a:default)))))
+
+ ;; Helper function for pretty-formatting the filtered members lists
+ ;; in a table.
+ (define (members-table-row a:? label mrs fmt)
+   (list (string-append "\t" a:? label)
+	 (length mrs)
+	 (ansi-paragraph-format
+	  (member-records->string
+	   (sort mrs member<?)
+	   fmt)
+	  60)))
+
+ ;; Prints nicely aligned members base info
+ (define (print-members-base-table mb)
+   (let* ((bi (members-base-info mb))
+	  (all-mrs (dict-ref bi 'total))
+	  (invalid-mrs (dict-ref bi 'invalid))
+	  (active-mrs (dict-ref bi 'active))
+	  (suspended-mrs (dict-ref bi 'suspended))
+	  (destroyed-mrs (dict-ref bi 'destroyed))
+	  (student-mrs (dict-ref bi 'students)))
+     (print "Known members: " (length all-mrs))
+     (newline)
+     (print
+      (table->string
+       (filter
+	identity
+	(list (list "Type" "Count" "List")
+	      (members-table-row a:success "Active:" active-mrs "~N~E")
+	      (members-table-row a:highlight "Students:" student-mrs "~N~E")
+	      (members-table-row a:warning "Suspended:" suspended-mrs "~N~E")
+	      (members-table-row a:warning "Destroyed:" destroyed-mrs "~N~E")
+	      (let ((suspended2 (filter-members-by-predicate
+				 suspended-mrs
+				 (lambda (mr)
+				   (>= (member-suspended-months mr)
+				       (*member-suspend-max-months*))))))
+		(if (null? suspended2)
+		    #f
+		    (members-table-row (ansi #:magenta) "Suspended (long):" suspended2 "~N (~S)")))
+	      ))
+       #:ansi #t
+       #:row-border #t
+       #:col-border #t
+       )))
+   (let ((pmrs (filter-members-by-predicate mb member-has-problems?)))
+     (when (not (null? pmrs))
+       (newline)
+       (print "Member files with errors (" (length pmrs) "): "
+	      (string-intersperse
+	       (map member-file-path pmrs)
+	       ", "))))
+   (let ((pmrs (filter-members-by-predicate mb (lambda (mr)
+						 (and (member-has-highlights? mr)
+						      (not (member-has-problems? mr)))))))
+     (when (not (null? pmrs))
+       (newline)
+       (print "Member files with issues: "
+	      (string-intersperse
+	       (map member-file-path pmrs)
+	       ", ")))))
+
+ ;; Prints the stats in format used by gnuplot.
+ (define (print-members-base-stats ms)
+   (let ((keys (car ms))
+	 (data (cadr ms)))
+     (print "# " (string-intersperse (map symbol->string keys) " "))
+     (let loop ((rows data))
+       (when (not (null? rows))
+	 (let* ((row (car rows))
+		(month (month->string (car row)))
+		(vals (cdr row)))
+	   (print month " " (string-intersperse (map number->string vals) " "))
+	   (loop (cdr rows)))))))
+
+ ;; Prints statistics about allocated and unused valid/invalid IDs.
+ (define (print-members-ids-stats MB)
+   (print "Allocated IDs: "
+	  (length (list-members-ids MB))
+	  "/"
+	  (length (gen-all-4digit-primes))
+	  " ("
+	  (length (get-free-members-ids MB))
+	  " free)")
+   (let ((iids (filter (compose not is-4digit-prime?) (list-members-ids MB))))
+     (when (not (null? iids))
+       (print "      Invalid: "
+	      (length iids)
+	      " ("
+	      (string-intersperse
+	       (map (lambda (id)
+		      (let ((mr (find-member-by-id MB id)))
+			(member-format
+			 "~I - ~N"
+			 mr)))
+		    iids)
+	       ", ")
+	      ")"))))
+
+ ;; Prints summary table of all fees and credits for all members
+ (define (print-members-fees-table MB)
+   (print
+    (table->string
+     (cons
+      (list (ansi-string #:bgblue #:brightyellow #:bold "Member")
+	    (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
+	(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)
+		  (sprintf "\t~A" fees)
+		  (sprintf "\t~A" credit)
+		  (sprintf "\t~A" payment)
+		  (sprintf "\t~A~A~A"
+			   (if (< total -500)
+			       a:error
+			       (if (< total 0)
+				   a:warning
+				   a:success))
+			   (exact->inexact total)
+			   a:default)
+		  )))
+	(sort (filter-members-by-predicate MB member-active?) member<?))
+       (let* ((balances (map member-balance MB))
+	      (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)))
+
+ )