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

Rename primitive accessors.

Browse source
This commit is contained in:
Dominik Pantůček 2023-04-11 22:05:29 +02:00
parent 5afdd8fb44
commit fb98eb6a78
2 changed files with 40 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

46
src/brmember.scm
View file

@ -35,13 +35,13 @@
brmember-file-path brmember-file-path
brmember-input-file brmember-input-file
member-record-set brmember-set
member-record-add-highlight brmember-add-highlight
member-record-sub-ref brmember-sub-ref
member-record-sub-set brmember-sub-set
member-record-sub-prepend brmember-sub-prepend
member-record-sub-has-key? brmember-sub-has-key?
member-record-sub-ensure brmember-sub-ensure
member-source member-source
member-record-info member-record-info
@ -143,58 +143,58 @@
(ldict-ref mr 'file-path))) (ldict-ref mr 'file-path)))
;; Sets pairs of keys/values for given member record. ;; Sets pairs of keys/values for given member record.
(define (member-record-set mr . args) (define (brmember-set mr . args)
(let loop ((args args) (let loop ((args args)
(mr mr)) (mr mr))
(if (null? args) (if (null? args)
mr mr
(if (not (keyword? (car args))) (if (not (keyword? (car args)))
(error 'member-record-set "Needs argument keyword" (car args)) (error 'brmember-set "Needs argument keyword" (car args))
(if (null? (cdr args)) (if (null? (cdr args))
(error 'member-record-set "Argument needs value" (car args)) (error 'brmember-set "Argument needs value" (car args))
(loop (cddr args) (loop (cddr args)
(ldict-set mr (string->symbol (keyword->string (car args))) (ldict-set mr (string->symbol (keyword->string (car args)))
(cadr args)))))))) (cadr args))))))))
;; Adds highlight identified by line number, message, pass number and ;; Adds highlight identified by line number, message, pass number and
;; type (error, warning, info). ;; type (error, warning, info).
(define (member-record-add-highlight mr line-number message pass type) (define (brmember-add-highlight mr line-number message pass type)
(ldict-set mr 'highlights (ldict-set mr 'highlights
(cons (list line-number message pass type) (cons (list line-number message pass type)
(ldict-ref mr 'highlights '())))) (ldict-ref mr 'highlights '()))))
;; Returns a key from particular section ;; Returns a key from particular section
(define (member-record-sub-ref mr sec key . defaults) (define (brmember-sub-ref mr sec key . defaults)
(let ((sec-dict (ldict-ref mr sec))) (let ((sec-dict (ldict-ref mr sec)))
(if (null? defaults) (if (null? defaults)
(ldict-ref sec-dict key) (ldict-ref sec-dict key)
(ldict-ref sec-dict key (car defaults))))) (ldict-ref sec-dict key (car defaults)))))
;; Sets a key in particular section ;; Sets a key in particular section
(define (member-record-sub-set mr sec key val) (define (brmember-sub-set mr sec key val)
(let ((sec-dict (ldict-ref mr sec))) (let ((sec-dict (ldict-ref mr sec)))
(ldict-set mr sec (ldict-set mr sec
(ldict-set sec-dict key val)))) (ldict-set sec-dict key val))))
;; Prepends value to given subkey ;; Prepends value to given subkey
(define (member-record-sub-prepend mr sec key val) (define (brmember-sub-prepend mr sec key val)
(member-record-sub-set mr sec key (brmember-sub-set mr sec key
(cons val (cons val
(member-record-sub-ref mr sec key '())))) (brmember-sub-ref mr sec key '()))))
;; Returns true if given section contains given key ;; Returns true if given section contains given key
(define (member-record-sub-has-key? mr sec key) (define (brmember-sub-has-key? mr sec key)
(ldict-contains? (ldict-ref mr sec) key)) (ldict-contains? (ldict-ref mr sec) key))
;; Returns new member record with section updated by defaults, the ;; Returns new member record with section updated by defaults, the
;; section must already exist. ;; section must already exist.
(define (member-record-sub-ensure mr sec . kvs) (define (brmember-sub-ensure mr sec . kvs)
(let loop ((kvs kvs) (let loop ((kvs kvs)
(sd (ldict-ref mr sec))) (sd (ldict-ref mr sec)))
(if (null? kvs) (if (null? kvs)
(ldict-set mr sec sd) (ldict-set mr sec sd)
(if (null? (cdr kvs)) (if (null? (cdr kvs))
(error 'member-record-sub-ensure "Needs pairs of keys and values" kvs) (error 'brmember-sub-ensure "Needs pairs of keys and values" kvs)
(let ((key (car kvs)) (let ((key (car kvs))
(val (cadr kvs))) (val (cadr kvs)))
(loop (cddr kvs) (loop (cddr kvs)
@ -369,14 +369,14 @@
(file-path . "members/1234") (file-path . "members/1234")
(symlinks |member|) (symlinks |member|)
(id . 1234))))) (id . 1234)))))
(test-true member-record-set (test-true brmember-set
(ldict-equal? (ldict-equal?
(member-record-set (make-ldict) #:id 1234) (brmember-set (make-ldict) #:id 1234)
(make-ldict (make-ldict
'((id . 1234))))) '((id . 1234)))))
(test-true member-record-add-highlight (test-true brmember-add-highlight
(ldict-equal? (ldict-equal?
(member-record-add-highlight (make-ldict) 123 "Interesting..." 0 'info) (brmember-add-highlight (make-ldict) 123 "Interesting..." 0 'info)
(make-ldict (make-ldict
'((highlights . ((123 "Interesting..." 0 info))))))) '((highlights . ((123 "Interesting..." 0 info)))))))
(test-true member-destroyed? (test-true member-destroyed?

34
src/member-parser.scm
View file

@ -84,13 +84,13 @@
(month (string->month (car mspec))) (month (string->month (car mspec)))
(comment (cdr mspec))) (comment (cdr mspec)))
(if month (if month
(member-record-sub-prepend (brmember-sub-prepend
mr output kind mr output kind
(list marker month (cdr value) comment)) (list marker month (cdr value) comment))
(member-record-add-highlight (brmember-add-highlight
mr (cdr value) "Invalid month specification" 3 'error)))) mr (cdr value) "Invalid month specification" 3 'error))))
mr value)) mr value))
(member-record-sub-set mr output key value)))) (brmember-sub-set mr output key value))))
(info (info
,(lambda (mr output key value) ,(lambda (mr output key value)
(case key (case key
@ -100,18 +100,18 @@
(periods (cadr res)) (periods (cadr res))
(msg (caddr res)) (msg (caddr res))
(line-number (cadddr res)) (line-number (cadddr res))
(mr1 (member-record-sub-set mr output key periods))) (mr1 (brmember-sub-set mr output key periods)))
(if ok? (if ok?
mr1 mr1
(member-record-add-highlight mr1 line-number msg 3 'error)))) (brmember-add-highlight mr1 line-number msg 3 'error))))
((card desfire) ((card desfire)
(member-record-sub-set mr output key (brmember-sub-set mr output key
(map (map
(lambda (rec) (lambda (rec)
(string-first+rest (car rec))) (string-first+rest (car rec)))
value))) value)))
((credit) ((credit)
(member-record-sub-set mr output key (brmember-sub-set mr output key
(map (map
(lambda (rec) (lambda (rec)
(let* ((fr (string-first+rest (car rec))) (let* ((fr (string-first+rest (car rec)))
@ -120,35 +120,35 @@
(cons amt msg))) (cons amt msg)))
value))) value)))
((nick) ((nick)
(let ((mr0 (member-record-sub-set mr output key (car value)))) (let ((mr0 (brmember-sub-set mr output key (car value))))
(if (irregex-search (irregex "[ \\t]" 'u) (car value)) (if (irregex-search (irregex "[ \\t]" 'u) (car value))
(member-record-add-highlight (brmember-add-highlight
mr0 (cdr value) "Whitespace not allowed in nick" 3 'error) mr0 (cdr value) "Whitespace not allowed in nick" 3 'error)
mr0))) mr0)))
(else (else
(member-record-sub-set mr output key (car value)))))))) (brmember-sub-set mr output key (car value))))))))
;; Pass 4: Final checks - add defaults ;; Pass 4: Final checks - add defaults
(define (member-schema-finalize mr) (define (member-schema-finalize mr)
(apply (apply
member-record-sub-ensure brmember-sub-ensure
mr 'info mr 'info
(join (map (lambda (mk) (list mk #f)) mandatory-keys)))) (join (map (lambda (mk) (list mk #f)) mandatory-keys))))
;; Passes 0 and 1: Adds parsed lines to member record. ;; Passes 0 and 1: Adds parsed lines to member record.
(define (parse-member-lines mr source) (define (parse-member-lines mr source)
(let loop ((lines source) (let loop ((lines source)
(mr (member-record-set mr #:source source)) (mr (brmember-set mr #:source source))
(result '()) (result '())
(line-number 1)) (line-number 1))
(if (null? lines) (if (null? lines)
(member-record-set mr #:parsed (reverse result)) (brmember-set mr #:parsed (reverse result))
(let ((parsed-line (parser-parse-line (let ((parsed-line (parser-parse-line
(parser-preprocess-line (parser-preprocess-line
(car lines))))) (car lines)))))
(loop (cdr lines) (loop (cdr lines)
(if (symbol? parsed-line) (if (symbol? parsed-line)
(member-record-add-highlight mr line-number "Got only key" 1 'error) (brmember-add-highlight mr line-number "Got only key" 1 'error)
mr) mr)
(if (pair? parsed-line) (if (pair? parsed-line)
(cons (list (car parsed-line) (cons (list (car parsed-line)
@ -167,7 +167,7 @@
(mr mr) (mr mr)
(processed (make-ldict))) (processed (make-ldict)))
(if (null? parsed) (if (null? parsed)
(member-record-set mr #:processed processed) (brmember-set mr #:processed processed)
(let* ((line (car parsed)) (let* ((line (car parsed))
(key (car line)) (key (car line))
(value (cadr line)) (value (cadr line))
@ -175,7 +175,7 @@
(if (member key known-keys) (if (member key known-keys)
(if (ldict-contains? processed key) (if (ldict-contains? processed key)
(loop (cdr parsed) (loop (cdr parsed)
(member-record-add-highlight mr number "Duplicate key" 2 'error) (brmember-add-highlight mr number "Duplicate key" 2 'error)
processed) processed)
(loop (cdr parsed) (loop (cdr parsed)
mr mr
@ -188,7 +188,7 @@
(loop (cdr parsed) (loop (cdr parsed)
(if (member key ignored-keys) (if (member key ignored-keys)
mr mr
(member-record-add-highlight mr number "Unknown key" 2 'warning)) (brmember-add-highlight mr number "Unknown key" 2 'warning))
processed))))))) processed)))))))
;; Pass 3+: Single interpreter pass - input must be ;; Pass 3+: Single interpreter pass - input must be