299 lines
9 KiB
Scheme
299 lines
9 KiB
Scheme
;;
|
|
;; member2-record.scm
|
|
;;
|
|
;; Procedures working with complete member record (as loaded by the
|
|
;; members-base).
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; 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 member2-record))
|
|
|
|
(module
|
|
member2-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-info
|
|
|
|
member-destroyed?
|
|
member-suspended?
|
|
member-active?
|
|
member-student?
|
|
member-existing?
|
|
|
|
member-nick
|
|
member-id
|
|
member-suspended-months
|
|
|
|
member-format
|
|
|
|
member-record-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken keyword)
|
|
(chicken irregex)
|
|
(chicken string)
|
|
(chicken format)
|
|
dictionary
|
|
testing
|
|
month
|
|
period
|
|
configuration)
|
|
|
|
;; 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))
|
|
|
|
;; checks whether given symbol is a 4-digit one.
|
|
(define (is-4digit-symbol? s)
|
|
(is-4digit-string?
|
|
(symbol->string 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 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 (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 (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*)))))
|
|
|
|
;; 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 (member-record-info mr 'highlights '()))))
|
|
(if (<= n 2)
|
|
""
|
|
(sprintf "[~A]" (- n 2)))))
|
|
((#\~) "~"))
|
|
resl))
|
|
(loop (cdr fmtl)
|
|
(cons (make-string 1 (car fmtl)) resl)))))))
|
|
;; 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")))))))
|
|
(test-false member-destroyed?
|
|
(parameterize ((*current-month* (list 2009 2)))
|
|
(member-destroyed? '((info . ((destroyed . "2010-05")))))))
|
|
(test-false member-destroyed?
|
|
(member-destroyed? '((info . ()))))
|
|
(test-false member-suspended?
|
|
(member-suspended? '((info . ()))))
|
|
(test-true member-suspended?
|
|
(parameterize ((*current-month* (list 2015 2)))
|
|
(member-suspended? '((info . ((suspend ((2010 1) 2022 4))))))))
|
|
(test-true member-suspended?
|
|
(parameterize ((*current-month* (list 2015 2)))
|
|
(member-suspended? '((info . ((suspend ((2010 1) . #f))))))))
|
|
(test-false member-suspended?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(member-suspended? '((info . ((suspend ((2010 1) 2022 4))))))))
|
|
(test-true member-active?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(member-active? '((info . ((suspend ((2010 1) 2022 4))))))))
|
|
))
|
|
|
|
)
|
|
|
|
(import member2-record)
|
|
|
|
(member-record-tests!)
|