;; ;; 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 ( make-member-record member-record-input-file member-record-set member-record-add-highlight member-record-sub-ref member-record-sub-set member-record-sub-prepend member-record-sub-has-key? member-record-sub-ensure member-record-info member-missing-keys member-highlights? member-valid? member-destroyed? member-suspended? member-active? member-student? member-existing? member-flags member-nick member-id member-suspended-months member-format memberstring s))) ;; Returns the first 4-digit symbol from the list. (define (get-4digit-symbol-from-list lst) (let loop ((lst lst)) (if (null? lst) #f (if (is-4digit-symbol? (car lst)) (car lst) (loop (cdr lst)))))) ;; Creates new member record based on the file and symlinks ;; information received from the members directory. Any keyword ;; arguments are converted to respective symbols in the dictionary. (define (make-member-record file-name file-path symlinks . args) (let loop ((args args) (pairs `((file-name . ,file-name) (file-path . ,file-path) (symlinks . ,symlinks) (id . ,(string->number (symbol->string (get-4digit-symbol-from-list (cons file-name symlinks)))))))) (if (null? args) (make-dict pairs) (if (not (keyword? (car args))) (error 'make-member-record "Optional arguments must be keywords" (car args)) (if (null? (cdr args)) (error 'make-member-record "Each optional keyword argument must have a value" (car args)) (loop (cddr args) (cons (cons (string->symbol (keyword->string (car args))) (cadr args)) pairs))))))) ;; Returns opened input file for this record (used by parser). (define (member-record-input-file mr) (open-input-file (dict-ref mr 'file-path))) ;; Sets pairs of keys/values for given member record. (define (member-record-set mr . args) (let loop ((args args) (mr mr)) (if (null? args) mr (if (not (keyword? (car args))) (error 'member-record-set "Needs argument keyword" (car args)) (if (null? (cdr args)) (error 'member-record-set "Argument needs value" (car args)) (loop (cddr args) (dict-set mr (string->symbol (keyword->string (car args))) (cadr args)))))))) ;; Adds highlight identified by line number, message, pass number and ;; type (error, warning, info). (define (member-record-add-highlight mr line-number message pass type) (dict-set mr 'highlights (cons (list line-number message pass type) (dict-ref mr 'highlights '())))) ;; Returns a key from particular section (define (member-record-sub-ref mr sec key . defaults) (let ((sec-dict (dict-ref mr sec))) (if (null? defaults) (dict-ref sec-dict key) (dict-ref sec-dict key (car defaults))))) ;; Sets a key in particular section (define (member-record-sub-set mr sec key val) (let ((sec-dict (dict-ref mr sec))) (dict-set mr sec (dict-set sec-dict key val)))) ;; Prepends value to given subkey (define (member-record-sub-prepend mr sec key val) (member-record-sub-set mr sec key (cons val (member-record-sub-ref mr sec key '())))) ;; Returns true if given section contains given key (define (member-record-sub-has-key? mr sec key) (dict-has-key? (dict-ref mr sec) key)) ;; Returns new member record with section updated by defaults, the ;; section must already exist. (define (member-record-sub-ensure mr sec . kvs) (let loop ((kvs kvs) (sd (dict-ref mr sec))) (if (null? kvs) (dict-set mr sec sd) (if (null? (cdr kvs)) (error 'member-record-sub-ensure "Needs pairs of keys and values" kvs) (let ((key (car kvs)) (val (cadr kvs))) (loop (cddr kvs) (if (dict-has-key? sd key) sd (dict-set sd key val)))))))) ;; Returns member info key value (define (member-record-info mr key . defaults) (let ((info (dict-ref mr 'info))) (if (null? defaults) (dict-ref info key) (dict-ref info key (car defaults))))) ;; Return mandatory keys with #f as value (define (member-missing-keys mr) (dict-reduce '() (lambda (acc k v) (if v acc (cons k acc))) (dict-ref mr 'info))) ;; True if there are any source highlights (define (member-highlights? mr) (dict-has-key? mr 'highlights)) ;; True if member record is OK (define (member-valid? mr) (and (not (member-highlights? mr)) (is-4digit-prime? (member-id mr)))) ;; 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 (member-record-info mr 'destroyed #f))) (and destroyed (monthmonth destroyed) (*current-month*))))) ;; Generic period-based predicate (define ((member-period-predicate? key) mr) (let ((periods (member-record-info 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)))) ;; Returns true if the member has joined. (define (member-existing? mr) (let ((joined (member-record-info mr 'joined))) (and joined (month<=? joined (*current-month*))))) ;; Returns a list of flags of given member record. (define (member-flags mr) (filter identity (list (if (member-student? mr) 'student #f) (if (member-suspended? mr) 'suspended #f) (if (member-active? mr) 'active #f) (if (member-destroyed? mr) 'destroyed #f) (if (member-existing? mr) 'existing #f)))) ;; Nickname as string (define (member-nick mr) (member-record-info mr 'nick)) ;; Returns member id (define (member-id mr) (dict-ref mr 'id)) ;; 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 (member-record-info mr 'suspend)))) (if period (month-diff (car period) (*current-month*)) 0)) 0)) ;; 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) (member-record-info mr 'nick)) ((#\I) (number->string (member-record-info mr 'id))) ((#\S) (number->string (member-suspended-months mr))) ((#\E) (let ((n (length (dict-ref mr 'highlights '())))) (if (eq? n 0) "" (sprintf "[~A]" n)))) ((#\~) "~")) resl)) (loop (cdr fmtl) (cons (make-string 1 (car fmtl)) resl))))))) ;; Comparator of member records based on nickname. (define (member