diff --git a/member-record-old.scm b/member-record-old.scm deleted file mode 100644 index 7d13ea3..0000000 --- a/member-record-old.scm +++ /dev/null @@ -1,291 +0,0 @@ -;; -;; 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 - print-member-record-table - 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))))))) - - ;; 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. - (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 - (month<=? joined (*current-month*))))) - - ;; Member formatting function for general use. - (define (member-format fmt mr) - (let loop ((fmtl (string->list 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