diff --git a/Makefile b/Makefile index e882898..5644836 100644 --- a/Makefile +++ b/Makefile @@ -143,7 +143,7 @@ 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 \ - progress.import.scm + progress.import.scm table.import.scm members-base.so: members-base.o members-base.o: members-base.import.scm @@ -164,7 +164,7 @@ primes.import.scm: $(PRIMES-SOURCES) MEMBER-RECORD-SOURCES=member-record.scm dictionary.import.scm \ period.import.scm testing.import.scm month.import.scm \ member-file.import.scm listing.import.scm ansi.import.scm \ - configuration.import.scm + configuration.import.scm table.import.scm utils.import.scm member-record.so: member-record.o member-record.o: member-record.import.scm diff --git a/bbstool.scm b/bbstool.scm index 1e734bb..8619514 100644 --- a/bbstool.scm +++ b/bbstool.scm @@ -126,7 +126,7 @@ CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. (print "Current month: " (month->string (*current-month*))) (newline) (if mr - (print-member-record-info mr) + (print-member-record-table mr) (print-members-base-info MB)) (newline)) ((print-stats) diff --git a/member-record.scm b/member-record.scm index e8b46c7..7d13ea3 100644 --- a/member-record.scm +++ b/member-record.scm @@ -30,6 +30,7 @@ member-record ( print-member-record-info + print-member-record-table member-destroyed? member-suspended? member-active? @@ -57,7 +58,9 @@ member-file listing ansi - configuration) + configuration + table + utils) ;; Prints human-readable information (define (print-member-record-info mr) @@ -88,6 +91,56 @@ v))) (loop (cdr sinfo))))))) + ;; Prints nicely formatted table + (define (print-member-record-table mr) + (let* ((aliases (mr-ref mr 'symlinks)) + (head (list (list "ID:" (mr-ref mr 'id)) + (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) + (stringstring a) + (symbol->string b))))) + (body (map (lambda (k) + (if (eq? k member-file-error-symbol) + #f + (let ((v (dict-ref info k))) + (case k + ((joined) + (list k (month->string v))) + ((card desfire credit) + (list k + (table->string + (map + (lambda (c) + (list (car c) (cdr c))) + v) + #:col-border #t))) + ((suspend student) + (list k + (table->string + (cons (list "Since" "Until") + (map + (lambda (p) + (list + (month->string (car p)) + (month->string (cdr p)))) + v)) + #:col-border #t))) + (else + (list k v)))))) + sikeys)) + (result (filter identity (append head body)))) + (print (table->string result #:table-border #t #:row-border #t #:col-border #t)))) + ;; Returns key from the top-level (members-base) record if it exists, ;; queries the 'info key otherwise. Optional default argument works ;; like with dict-ref. diff --git a/month.scm b/month.scm index cdeca15..4130c6a 100644 --- a/month.scm +++ b/month.scm @@ -87,14 +87,16 @@ ;; Formats (valid) month as YYYY-MM string (define (month->string M) - (if (month-valid? M) - (let ((y (car M)) - (m (cadr M))) - (sprintf "~A-~A~A" - y - (if (< m 10) "0" "") - m)) - (error 'string->month "Invalid month" M))) + (if M + (if (month-valid? M) + (let ((y (car M)) + (m (cadr M))) + (sprintf "~A-~A~A" + y + (if (< m 10) "0" "") + m)) + (error 'string->month "Invalid month" M)) + "____-__")) ;; Returns true if both arguments are a valid month and are equal (define (month=? m n) diff --git a/table.scm b/table.scm index 8ae4ef6..43d8d59 100644 --- a/table.scm +++ b/table.scm @@ -31,10 +31,6 @@ *table-border-style* table->string table-tests! - ;;--- - table-row-delimiter - table-row-delimiter/styled - table-borders-lookup ) (import scheme @@ -48,7 +44,20 @@ utils) ;; Default table border style to use if not explicitly specified. - (define *table-border-style* (make-parameter 'ascii)) + (define *table-border-style* (make-parameter 'unicode)) + + ;; Table border styles in visual form + (define table-borders-lookup-source + '((ascii + "/=,\\" + "] |[" + ">-+<" + "'~^`") + (unicode + "┌─┬┐" + "│ ││" + "├─┼┤" + "└─┴┘"))) ;; Returns a list of strings representing the rows in the original ;; string. @@ -130,9 +139,9 @@ (reverse r) (loop (cdr c) (cons (let* ((cs (car c)) - (csl (string-length cs))) + (csl (ansi-string-length cs))) (if (< csl w) - (string-append cs (make-string (- w csl) #\space)) + (string-append cs (string-repeat " " (- w csl))) cs)) r))))) @@ -165,19 +174,6 @@ (table-stringify (table-rectangularize tbl)))))) - ;; Table border styles in visual form - (define table-borders-lookup-source - '((ascii - "/=,\\" - "] |[" - ">-+<" - "'~^`") - (unicode - "┌─┬┐" - "│ ││" - "├─┼┤" - "└─┴┘"))) - ;; Compiled table borders for rendering (define table-borders-lookup (map (lambda (src) @@ -237,7 +233,7 @@ (let* ((table-border (get-keyword #:table-border args (lambda () #f))) (row-border (get-keyword #:row-border args (lambda () #f))) (column-border (get-keyword #:col-border args (lambda () #f))) - (border-style (get-keyword #:border-style args (lambda () 'ascii))) + (border-style (get-keyword #:border-style args (lambda () (*table-border-style*)))) (stylepair (assq border-style table-borders-lookup)) (stylevec (if stylepair