brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Work on migrating to the new dictionary implementation.

Browse source
This commit is contained in:
Dominik Pantůček 2023-04-09 20:36:49 +02:00
parent 42466416cd
commit ced789ca06
7 changed files with 69 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

70
src/member-record.scm
View file

@ -80,7 +80,7 @@
(chicken irregex)
(chicken string)
(chicken format)
dictionary
util-dict-list
testing
month
period
@ -121,7 +121,7 @@
(symbol->string
(get-4digit-symbol-from-list (cons file-name symlinks))))))))
(if (null? args)
(make-dict pairs)
(make-ldict pairs)
(if (not (keyword? (car args)))
(error 'make-member-record "Optional arguments must be keywords" (car args))
(if (null? (cdr args))
@ -133,16 +133,16 @@
;; File name without directory
(define (member-file-name mr)
(dict-ref mr 'file-name))
(ldict-ref mr 'file-name))
;; Convenience accessor for file name with directory
(define (member-file-path mr)
(dict-ref mr 'file-path))
(ldict-ref mr 'file-path))
;; Returns opened input file for this record (used by parser).
(define (member-record-input-file mr)
(open-input-file
(dict-ref mr 'file-path)))
(ldict-ref mr 'file-path)))
;; Sets pairs of keys/values for given member record.
(define (member-record-set mr . args)
@ -155,28 +155,28 @@
(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)))
(ldict-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
(ldict-set mr 'highlights
(cons (list line-number message pass type)
(dict-ref mr 'highlights '()))))
(ldict-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)))
(let ((sec-dict (ldict-ref mr sec)))
(if (null? defaults)
(dict-ref sec-dict key)
(dict-ref sec-dict key (car defaults)))))
(ldict-ref sec-dict key)
(ldict-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))))
(let ((sec-dict (ldict-ref mr sec)))
(ldict-set mr sec
(ldict-set sec-dict key val))))
;; Prepends value to given subkey
(define (member-record-sub-prepend mr sec key val)
@ -186,49 +186,49 @@
;; 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))
(ldict-contains? (ldict-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)))
(sd (ldict-ref mr sec)))
(if (null? kvs)
(dict-set mr sec sd)
(ldict-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)
(if (ldict-contains? sd key)
sd
(dict-set sd key val))))))))
(ldict-set sd key val))))))))
;; Returns source lines
(define (member-source mr)
(dict-ref mr 'source '()))
(ldict-ref mr 'source '()))
;; Returns member info key value
(define (member-record-info mr key . defaults)
(let ((info (dict-ref mr 'info)))
(let ((info (ldict-ref mr 'info)))
(if (null? defaults)
(dict-ref info key)
(dict-ref info key (car defaults)))))
(ldict-ref info key)
(ldict-ref info key (car defaults)))))
;; Return mandatory keys with #f as value
(define (member-missing-keys mr)
(dict-reduce '()
(ldict-reduce '()
(lambda (acc k v)
(if v acc (cons k acc)))
(dict-ref mr 'info)))
(ldict-ref mr 'info)))
;; True if there are any source highlights
(define (member-has-highlights? mr)
(dict-has-key? mr 'highlights))
(ldict-contains? mr 'highlights))
;; Returns true if there is at least one highlight of given type
(define (member-highlights-has-type? mr type)
(let loop ((hls (dict-ref mr 'highlights '())))
(let loop ((hls (ldict-ref mr 'highlights '())))
(if (null? hls)
#f
(if (eq? (cadddr (car hls)) type)
@ -241,7 +241,7 @@
;; Absolutely required
(define (member-record-usable? mr)
(dict-has-key? (dict-ref mr 'info) 'member))
(ldict-contains? (ldict-ref mr 'info) 'member))
;; True if member record is OK
(define (member-has-problems? mr)
@ -309,7 +309,7 @@
;; Returns member id
(define (member-id mr)
(dict-ref mr 'id))
(ldict-ref mr 'id))
;; Returns the number of months the user is suspended. Zero if not
;; suspended.
@ -335,7 +335,7 @@
((#\I) (number->string (member-record-info mr 'id)))
((#\S) (number->string (member-suspended-months mr)))
((#\E)
(let ((n (length (dict-ref mr 'highlights '()))))
(let ((n (length (ldict-ref mr 'highlights '()))))
(if (eq? n 0)
""
(sprintf "[~A]" n))))
@ -351,9 +351,9 @@
;; Prepends new payment to given member record payments
(define (member-record-add-payment mr pt)
(dict-set mr 'payments
(ldict-set mr 'payments
(cons pt
(dict-ref mr 'payments '()))))
(ldict-ref mr 'payments '()))))
;; Returns alist of member payments
(define (member-payments mr)
@ -361,15 +361,15 @@
(let* ((isodate (bank-transaction-date tr))
(month (iso-date->month isodate)))
(month<=? month (*current-month*))))
(dict-ref mr 'payments '())))
(ldict-ref mr 'payments '())))
;; Returns a list of MLs this member is subscribed to
(define (member-mailman mr)
(dict-ref mr 'mailman '()))
(ldict-ref mr 'mailman '()))
;; Adds given ML to given member record
(define (member-add-mailman mr ml)
(dict-set mr 'mailman
(ldict-set mr 'mailman
(cons ml
(member-mailman mr))))