265 lines
7.5 KiB
Scheme
265 lines
7.5 KiB
Scheme
;;
|
|
;; brmember-parser.scm
|
|
;;
|
|
;; Member file parsing.
|
|
;;
|
|
;; 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 brmember-parser))
|
|
|
|
(module
|
|
brmember-parser
|
|
(
|
|
load-brmember-file
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken io)
|
|
(chicken irregex)
|
|
(chicken string)
|
|
brmember
|
|
testing
|
|
util-dict-list
|
|
cal-month
|
|
cal-period
|
|
util-list
|
|
configuration
|
|
util-string
|
|
util-parser
|
|
cal-day)
|
|
|
|
;; Pass 2: known keys
|
|
(define mandatory-keys '(nick name mail phone))
|
|
(define optional-keys '(born))
|
|
(define known-multikeys
|
|
'(card desfire
|
|
credit
|
|
studentstart studentstop
|
|
suspendstart suspendstop
|
|
chairstart chairstop
|
|
councilstart councilstop
|
|
revisionstart revisionstop
|
|
grantstart grantstop
|
|
joined destroyed))
|
|
(define ignored-keys '(mail2))
|
|
|
|
(define known-keys (append mandatory-keys optional-keys))
|
|
|
|
;; Dynamic start/stop markers
|
|
(define start-stop-markers-lookup
|
|
'(
|
|
(studentstart student start)
|
|
(studentstop student stop)
|
|
(suspendstart suspend start)
|
|
(suspendstop suspend stop)
|
|
|
|
(chairstart chair start)
|
|
(chairstop chair stop)
|
|
(councilstart council start)
|
|
(councilstop council stop)
|
|
(revisionstart revision start)
|
|
(revisionstop revision stop)
|
|
(grantstart grant start)
|
|
(grantstop grant stop)
|
|
|
|
(joined member start)
|
|
(destroyed member stop)
|
|
))
|
|
(define start-stop-markers (map car start-stop-markers-lookup))
|
|
|
|
;; Pass 3: Interpreter passes
|
|
(define member-schema-interpreters
|
|
`((pass-markers
|
|
,(lambda (mr output key value)
|
|
(if (member key start-stop-markers)
|
|
(let* ((mk (assq key start-stop-markers-lookup))
|
|
(marker (caddr mk))
|
|
(kind (cadr mk)))
|
|
(foldl (lambda (mr value)
|
|
(let* ((mspec (string-first+rest (car value)))
|
|
(month (parse-cal-day/month (car mspec)))
|
|
(comment (cdr mspec)))
|
|
(if month
|
|
(brmember-sub-prepend
|
|
mr output kind
|
|
(list marker month (cdr value) comment))
|
|
(brmember-add-highlight
|
|
mr (cdr value) "Invalid month specification" 3 'error))))
|
|
mr value))
|
|
(brmember-sub-set mr output key value))))
|
|
(info
|
|
,(lambda (mr output key value)
|
|
(case key
|
|
((student suspend member)
|
|
(let* ((res (period-markers->cal-periods value))
|
|
(ok? (car res))
|
|
(periods (cadr res))
|
|
(msg (caddr res))
|
|
(line-number (cadddr res))
|
|
(mr1 (brmember-sub-set mr output key periods)))
|
|
(if ok?
|
|
mr1
|
|
(brmember-add-highlight mr1 line-number msg 3 'error))))
|
|
((card desfire)
|
|
(brmember-sub-set mr output key
|
|
(map
|
|
(lambda (rec)
|
|
(string-first+rest (car rec)))
|
|
value)))
|
|
((credit)
|
|
(let loop ((mr mr)
|
|
(src-credits value)
|
|
(credits '()))
|
|
(if (null? src-credits)
|
|
(brmember-sub-set mr output key credits)
|
|
(let* ((rec (caar src-credits))
|
|
(line-number (cdar src-credits))
|
|
(fr (string-first+rest rec))
|
|
(amt (string->number (car fr)))
|
|
(msg (cdr fr))
|
|
(mlst (string-split msg))
|
|
(mon (if (null? mlst)
|
|
#f
|
|
(parse-cal-day/month (car mlst))))
|
|
(rmsg (if mon
|
|
(string-intersperse (cdr mlst) " ")
|
|
msg)))
|
|
(loop (if mon
|
|
mr
|
|
(brmember-add-highlight mr line-number
|
|
"missing date or month information"
|
|
3
|
|
'warning))
|
|
(cdr src-credits)
|
|
(cons (list amt mon rmsg)
|
|
credits))))))
|
|
((nick)
|
|
(let ((mr0 (brmember-sub-set mr output key (car value))))
|
|
(if (irregex-search (irregex "[ \\t]" 'u) (car value))
|
|
(brmember-add-highlight
|
|
mr0 (cdr value) "Whitespace not allowed in nick" 3 'error)
|
|
mr0)))
|
|
(else
|
|
(brmember-sub-set mr output key (car value))))))))
|
|
|
|
;; Pass 4: Final checks - add defaults
|
|
(define (member-schema-finalize mr)
|
|
(apply
|
|
brmember-sub-ensure
|
|
mr 'info
|
|
(join (map (lambda (mk) (list mk #f)) mandatory-keys))))
|
|
|
|
;; Passes 0 and 1: Adds parsed lines to member record.
|
|
(define (parse-member-lines mr source)
|
|
(let loop ((lines source)
|
|
(mr (brmember-set mr #:source source))
|
|
(result '())
|
|
(line-number 1))
|
|
(if (null? lines)
|
|
(brmember-set mr #:parsed (reverse result))
|
|
(let ((parsed-line (parser-parse-line
|
|
(parser-preprocess-line
|
|
(car lines)))))
|
|
(loop (cdr lines)
|
|
(if (symbol? parsed-line)
|
|
(brmember-add-highlight mr line-number "Got only key" 1 'error)
|
|
mr)
|
|
(if (pair? parsed-line)
|
|
(cons (list (car parsed-line)
|
|
(cdr parsed-line)
|
|
line-number)
|
|
result)
|
|
result)
|
|
(add1 line-number))))))
|
|
|
|
;; Pass 2: Converts parsed key/value/line records into a proper
|
|
;; dictionary. Known keys are stored as pairs of value and line
|
|
;; number, known multikeys as lists of pairs of value and line
|
|
;; number.
|
|
(define (process-member-file mr)
|
|
(let loop ((parsed (ldict-ref mr 'parsed))
|
|
(mr mr)
|
|
(processed (make-ldict)))
|
|
(if (null? parsed)
|
|
(brmember-set mr #:processed processed)
|
|
(let* ((line (car parsed))
|
|
(key (car line))
|
|
(value (cadr line))
|
|
(number (caddr line)))
|
|
(if (member key known-keys)
|
|
(if (ldict-contains? processed key)
|
|
(loop (cdr parsed)
|
|
(brmember-add-highlight mr number "Duplicate key" 2 'error)
|
|
processed)
|
|
(loop (cdr parsed)
|
|
mr
|
|
(ldict-set processed key (cons value number))))
|
|
(if (member key known-multikeys)
|
|
(loop (cdr parsed)
|
|
mr
|
|
(ldict-set processed key (cons (cons value number)
|
|
(ldict-ref processed key '()))))
|
|
(loop (cdr parsed)
|
|
(if (member key ignored-keys)
|
|
mr
|
|
(brmember-add-highlight mr number "Unknown key" 2 'warning))
|
|
processed)))))))
|
|
|
|
;; Pass 3+: Single interpreter pass - input must be
|
|
;; dictionary. Output is top-level key of member record.
|
|
(define (interpreter-pass mr output input pass-proc)
|
|
(let loop ((keys (ldict-keys input))
|
|
(mr (ldict-set mr output (make-ldict))))
|
|
(if (null? keys)
|
|
mr
|
|
(let ((key (car keys)))
|
|
(loop (cdr keys)
|
|
(pass-proc mr output key
|
|
(ldict-ref input key)))))))
|
|
|
|
;; Pass 3+: Interpreter passes
|
|
(define (interpret-member-file mr . starts)
|
|
(let ((input-name (if (null? starts)
|
|
'processed
|
|
(car starts))))
|
|
(let loop ((passes member-schema-interpreters)
|
|
(prev-name input-name)
|
|
(mr mr))
|
|
(if (null? passes)
|
|
mr
|
|
(let* ((pass (car passes))
|
|
(pass-name (car pass))
|
|
(pass-proc (cadr pass)))
|
|
(loop (cdr passes)
|
|
(caar passes)
|
|
(interpreter-pass mr pass-name (ldict-ref mr prev-name) pass-proc)))))))
|
|
|
|
;; Loads member file source. Performs passes 0, 1 and 2.
|
|
(define (load-brmember-file mr)
|
|
(let* ((mrif (brmember-input-file mr))
|
|
(source (read-lines mrif))
|
|
(mrp (parse-member-lines mr source)))
|
|
(member-schema-finalize
|
|
(interpret-member-file
|
|
(process-member-file mrp)))))
|
|
|
|
)
|