Start replacing member record.
This commit is contained in:
parent
16a2d85abd
commit
ade6d83f84
3 changed files with 452 additions and 452 deletions
|
|
@ -1,5 +1,5 @@
|
|||
;;
|
||||
;; member-record.scm
|
||||
;; member2-record.scm
|
||||
;;
|
||||
;; Procedures working with complete member record (as loaded by the
|
||||
;; members-base).
|
||||
|
|
@ -24,144 +24,155 @@
|
|||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
||||
;;
|
||||
|
||||
(declare (unit member-record))
|
||||
(declare (unit member2-record))
|
||||
|
||||
(module
|
||||
member-record
|
||||
member2-record
|
||||
(
|
||||
print-member-record-info
|
||||
print-member-record-table
|
||||
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-info
|
||||
|
||||
member-destroyed?
|
||||
member-suspended?
|
||||
member-active?
|
||||
member-student?
|
||||
member-existing?
|
||||
|
||||
member-nick
|
||||
member-id
|
||||
member-existing?
|
||||
member-format
|
||||
member-suspended-months
|
||||
member-source
|
||||
print-member-source
|
||||
member<?
|
||||
|
||||
member-format
|
||||
|
||||
member-record-tests!
|
||||
)
|
||||
|
||||
(import scheme
|
||||
(chicken base)
|
||||
(chicken keyword)
|
||||
(chicken irregex)
|
||||
(chicken string)
|
||||
(chicken sort)
|
||||
(chicken format)
|
||||
dictionary
|
||||
period
|
||||
testing
|
||||
month
|
||||
member-file
|
||||
listing
|
||||
ansi
|
||||
configuration
|
||||
table
|
||||
utils)
|
||||
period
|
||||
configuration)
|
||||
|
||||
;; Prints human-readable information
|
||||
(define (print-member-record-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)))
|
||||
(when (not (eq? k member-file-error-symbol))
|
||||
(print " " k ":\t"
|
||||
(if (member k '(student suspend))
|
||||
(periods->string v)
|
||||
v)))
|
||||
(loop (cdr sinfo)))))))
|
||||
;; Checks whether given string is a 4-digit decimal number.
|
||||
(define (is-4digit-string? s)
|
||||
(if (irregex-search (irregex "^[0-9]{4}$") s)
|
||||
#t
|
||||
#f))
|
||||
|
||||
;; 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)
|
||||
(string<?
|
||||
(symbol->string 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))))
|
||||
;; checks whether given symbol is a 4-digit one.
|
||||
(define (is-4digit-symbol? s)
|
||||
(is-4digit-string?
|
||||
(symbol->string s)))
|
||||
|
||||
;; 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 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 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)))))
|
||||
|
||||
;; 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)))
|
||||
(let ((destroyed (member-record-info mr 'destroyed #f)))
|
||||
(and destroyed
|
||||
(month<? (string->month destroyed)
|
||||
(*current-month*)))))
|
||||
|
||||
;; Generic period-based predicate
|
||||
(define ((member-period-predicate? key) mr)
|
||||
(let ((periods (mr-ref mr key #f)))
|
||||
(let ((periods (member-record-info mr key #f)))
|
||||
(and periods
|
||||
(month-in-periods? periods))))
|
||||
|
||||
|
|
@ -188,19 +199,29 @@
|
|||
(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*)))))
|
||||
|
||||
;; Nickname as string
|
||||
(define (member-nick mr)
|
||||
(mr-ref mr 'nick))
|
||||
(member-record-info mr 'nick))
|
||||
|
||||
;; Returns member id
|
||||
(define (member-id mr)
|
||||
(mr-ref mr 'id))
|
||||
(dict-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*)))))
|
||||
;; 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)
|
||||
|
|
@ -212,11 +233,11 @@
|
|||
(if (eq? ch #\~)
|
||||
(loop (cddr fmtl)
|
||||
(cons (case (cadr fmtl)
|
||||
((#\N) (mr-ref mr 'nick))
|
||||
((#\I) (number->string (mr-ref mr 'id)))
|
||||
((#\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 (mr-ref mr member-file-error-symbol '()))))
|
||||
(let ((n (length (member-record-info mr 'highlights '()))))
|
||||
(if (<= n 2)
|
||||
""
|
||||
(sprintf "[~A]" (- n 2)))))
|
||||
|
|
@ -224,46 +245,29 @@
|
|||
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<? a b)
|
||||
(string-ci<? (member-nick a)
|
||||
(member-nick b)))
|
||||
|
||||
;; Performs module self-tests.
|
||||
;; Self-tests
|
||||
(define (member-record-tests!)
|
||||
(run-tests
|
||||
member-record
|
||||
(test-equal? make-member-record
|
||||
(make-member-record '|1234| "members/1234" '(|member|))
|
||||
'((file-name . |1234|)
|
||||
(file-path . "members/1234")
|
||||
(symlinks |member|)
|
||||
(id . 1234)))
|
||||
(test-equal? make-member-record
|
||||
(make-member-record '|1234| "members/1234" '(|member|) #:msg "msg")
|
||||
'((msg . "msg")
|
||||
(file-name . |1234|)
|
||||
(file-path . "members/1234")
|
||||
(symlinks |member|)
|
||||
(id . 1234)))
|
||||
(test-equal? member-record-set
|
||||
(member-record-set '() #:id 1234)
|
||||
'((id . 1234)))
|
||||
(test-equal? member-record-add-highlight
|
||||
(member-record-add-highlight '() 123 "Interesting..." 0 'info)
|
||||
'((highlights . ((123 "Interesting..." 0 info)))))
|
||||
(test-true member-destroyed?
|
||||
(parameterize ((*current-month* (list 2023 2)))
|
||||
(member-destroyed? '((info . ((destroyed . "2010-05")))))))
|
||||
|
|
@ -289,3 +293,7 @@
|
|||
))
|
||||
|
||||
)
|
||||
|
||||
(import member2-record)
|
||||
|
||||
(member-record-tests!)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue