;; ;; member-record.scm ;; ;; Procedures working with complete member record (as loaded by the ;; members-base). ;; ;; ISC License ;; ;; Copyright 2023 Brmlab, z.s. ;; Dominik Pantůček ;; ;; 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 member-record)) (module member-record ( print-member-record-info member-destroyed? member-suspended? member-active? member-student? member-nick member-id member-existing? member-format member-suspended-months member-source print-member-source memberstring (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))) (when (not (eq? k member-file-error-symbol)) (print " " k ":\t" (if (member k '(student suspend)) (periods->string v) v))) (loop (cdr sinfo))))))) ;; 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. (define (mr-ref mr key . dfl) (if (dict-has-key? mr key) (dict-ref mr key) (if (null? dfl) (dict-ref (dict-ref mr 'info (make-dict)) key) (dict-ref (dict-ref mr 'info (make-dict)) key (car dfl))))) ;; Returns true if the member record represents destroyed member. The ;; *current-month* is a global parameter from period module. (define (member-destroyed? mr) (let ((destroyed (mr-ref mr 'destroyed #f))) (and destroyed (monthmonth destroyed) (*current-month*))))) ;; Generic period-based predicate (define ((member-period-predicate? key) mr) (let ((periods (mr-ref mr key #f))) (and periods (month-in-periods? periods)))) ;; Returns true if the member is now suspended (define member-is-suspended? (member-period-predicate? 'suspend)) ;; Suspended must not be destroyed (define (member-suspended? mr) (and (member-is-suspended? mr) (not (member-destroyed? mr)))) ;; True if the member is student (define member-is-student? (member-period-predicate? 'student)) ;; Only active members can be students. (define (member-student? mr) (and (member-active? mr) (member-is-student? mr))) ;; Returns true if the member is active (not suspended or destroyed). (define (member-active? mr) (and (not (member-destroyed? mr)) (not (member-suspended? mr)))) ;; Nickname as string (define (member-nick mr) (mr-ref mr 'nick)) ;; Returns member id (define (member-id mr) (mr-ref mr 'id)) ;; Returns true if the member has joined. (define (member-existing? mr) (let ((joined (mr-ref mr 'joined))) (and joined (monthlist fmt)) (resl '())) (if (null? fmtl) (string-intersperse (reverse resl) "") (let ((ch (car fmtl))) (if (eq? ch #\~) (loop (cddr fmtl) (cons (case (cadr fmtl) ((#\N) (mr-ref mr 'nick)) ((#\I) (number->string (mr-ref mr 'id))) ((#\S) (number->string (member-suspended-months mr))) ((#\E) (let ((n (length (mr-ref mr member-file-error-symbol '())))) (if (<= n 2) "" (sprintf "[~A]" (- n 2))))) ((#\~) "~")) resl)) (loop (cdr fmtl) (cons (make-string 1 (car fmtl)) resl))))))) ;; Returns the number of months the user is suspended. Zero if not ;; suspended. (define (member-suspended-months mr) (if (member-suspended? mr) (let ((period (periods-match (mr-ref mr 'suspend)))) (if period (month-diff (car period) (*current-month*)) 0)) 0)) ;; Returns source (including error) information (define (member-source mr) (mr-ref mr member-file-error-symbol)) ;; Nicely prints the member source with any errors recorded. (define (print-member-source mr) (let* ((ms (member-source mr)) (file-name (car ms)) (lines (cadr ms)) (hls (cddr ms))) (print file-name ":") (print-source-listing lines hls -1 a:error a:default "" "" ; Not used "..." ; Not used ))) ;; Comparator of member records based on nickname. (define (member