300 lines
9 KiB
Scheme
300 lines
9 KiB
Scheme
;;
|
|
;; member-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 member-parser))
|
|
|
|
(module
|
|
member-parser
|
|
(
|
|
load-member-file
|
|
member-parser-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken io)
|
|
(chicken irregex)
|
|
member-record
|
|
testing
|
|
dictionary
|
|
month
|
|
period
|
|
utils
|
|
configuration)
|
|
|
|
;; 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
|
|
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)
|
|
|
|
(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 (string->month (car mspec)))
|
|
(comment (cdr mspec)))
|
|
(if month
|
|
(member-record-sub-prepend
|
|
mr output kind
|
|
(list marker month (cdr value) comment))
|
|
(member-record-add-highlight
|
|
mr (cdr value) "Invalid month specification" 3 'error))))
|
|
mr value))
|
|
(member-record-sub-set mr output key value))))
|
|
(info
|
|
,(lambda (mr output key value)
|
|
(case key
|
|
((student suspend member)
|
|
(let* ((res (period-markers->periods value))
|
|
(ok? (car res))
|
|
(periods (cadr res))
|
|
(msg (caddr res))
|
|
(line-number (cadddr res))
|
|
(mr1 (member-record-sub-set mr output key periods)))
|
|
(if ok?
|
|
mr1
|
|
(member-record-add-highlight mr1 line-number msg 3 'error))))
|
|
((joined)
|
|
(let* ((month (string->month (car value)))
|
|
(mr0 (member-record-sub-set mr output key month)))
|
|
(if month
|
|
mr0
|
|
(member-record-add-highlight
|
|
mr0 (cdr value) "Invalid month specification" 3 'error))))
|
|
((card desfire)
|
|
(member-record-sub-set mr output key
|
|
(map
|
|
(lambda (rec)
|
|
(string-first+rest (car rec)))
|
|
value)))
|
|
((credit)
|
|
(member-record-sub-set mr output key
|
|
(map
|
|
(lambda (rec)
|
|
(let* ((fr (string-first+rest (car rec)))
|
|
(amt (string->number (car fr)))
|
|
(msg (cdr fr)))
|
|
(cons amt msg)))
|
|
value)))
|
|
((nick)
|
|
(let ((mr0 (member-record-sub-set mr output key (car value))))
|
|
(if (irregex-search (irregex "[ \\t]" 'u) (car value))
|
|
(member-record-add-highlight
|
|
mr0 (cdr value) "Whitespace not allowed in nick" 3 'error)
|
|
mr0)))
|
|
(else
|
|
(member-record-sub-set mr output key (car value))))))))
|
|
|
|
;; Pass 4: Final checks - add defaults
|
|
(define (member-schema-finalize mr)
|
|
(apply
|
|
member-record-sub-ensure
|
|
mr 'info
|
|
'member (make-period (*member-default-joined*) #f)
|
|
(join (map (lambda (mk) (list mk #f)) mandatory-keys))))
|
|
|
|
;; Pass 0: Removes any comments and removes any leading and trailing
|
|
;; whitespace.
|
|
(define (preprocess-member-line line)
|
|
(irregex-replace (irregex "[ \\t]*$" 'u)
|
|
(irregex-replace (irregex "^[ \\t]*" 'u)
|
|
(irregex-replace (irregex "#.*$" 'u) line "")
|
|
"")
|
|
""))
|
|
|
|
;; Pass 1: Expects line with comments and surrounding whitespace
|
|
;; removed, returns either #f if nothing was parsed, symbol if only
|
|
;; one token was there and pair of symbol and string if both key and
|
|
;; the value were present.
|
|
(define (parse-member-line line)
|
|
(if (= (string-length line) 0)
|
|
#f
|
|
(let ((dm (irregex-search (irregex "[ \\t]" 'u) line)))
|
|
(if dm
|
|
(let* ((sep-idx (irregex-match-start-index dm))
|
|
(key-str (substring line 0 sep-idx))
|
|
(key (string->symbol key-str))
|
|
(sep+val (substring line sep-idx))
|
|
(val (irregex-replace (irregex "^[ \\t]*" 'u) sep+val "")))
|
|
(cons key val))
|
|
(string->symbol line)))))
|
|
|
|
;; Passes 0 and 1: Adds parsed lines to member record.
|
|
(define (parse-member-lines mr source)
|
|
(let loop ((lines source)
|
|
(mr (member-record-set mr #:source source))
|
|
(result '())
|
|
(line-number 1))
|
|
(if (null? lines)
|
|
(member-record-set mr #:parsed (reverse result))
|
|
(let ((parsed-line (parse-member-line
|
|
(preprocess-member-line
|
|
(car lines)))))
|
|
(loop (cdr lines)
|
|
(if (symbol? parsed-line)
|
|
(member-record-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 (dict-ref mr 'parsed))
|
|
(mr mr)
|
|
(processed (make-dict)))
|
|
(if (null? parsed)
|
|
(member-record-set mr #:processed processed)
|
|
(let* ((line (car parsed))
|
|
(key (car line))
|
|
(value (cadr line))
|
|
(number (caddr line)))
|
|
(if (member key known-keys)
|
|
(if (dict-has-key? processed key)
|
|
(loop (cdr parsed)
|
|
(member-record-add-highlight mr number "Duplicate key" 2 'error)
|
|
processed)
|
|
(loop (cdr parsed)
|
|
mr
|
|
(dict-set processed key (cons value number))))
|
|
(if (member key known-multikeys)
|
|
(loop (cdr parsed)
|
|
mr
|
|
(dict-set processed key (cons (cons value number)
|
|
(dict-ref processed key '()))))
|
|
(loop (cdr parsed)
|
|
(if (member key ignored-keys)
|
|
mr
|
|
(member-record-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 (dict-keys input))
|
|
(mr (dict-set mr output (make-dict))))
|
|
(if (null? keys)
|
|
mr
|
|
(let ((key (car keys)))
|
|
(loop (cdr keys)
|
|
(pass-proc mr output key
|
|
(dict-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 (dict-ref mr prev-name) pass-proc)))))))
|
|
|
|
;; Loads member file source. Performs passes 0, 1 and 2.
|
|
(define (load-member-file mr)
|
|
(let* ((mrif (member-record-input-file mr))
|
|
(source (read-lines mrif))
|
|
(mrp (parse-member-lines mr source)))
|
|
(member-schema-finalize
|
|
(interpret-member-file
|
|
(process-member-file mrp)))))
|
|
|
|
;; Performs self-tests of the member-parser module.
|
|
(define (member-parser-tests!)
|
|
(run-tests
|
|
member-parser
|
|
(test-equal? preprocess-member-line
|
|
(preprocess-member-line "# all comment")
|
|
"")
|
|
(test-equal? preprocess-member-line
|
|
(preprocess-member-line " # all comment after spaces")
|
|
"")
|
|
(test-equal? preprocess-member-line
|
|
(preprocess-member-line " test # spaces and comment after spaces")
|
|
"test")
|
|
(test-equal? preprocess-member-line
|
|
(preprocess-member-line "key value # spaces and comment after spaces")
|
|
"key value")
|
|
(test-false parse-member-line
|
|
(parse-member-line ""))
|
|
(test-eq? parse-member-line
|
|
(parse-member-line "key")
|
|
'key)
|
|
(test-equal? parse-member-line
|
|
(parse-member-line "key value")
|
|
'(key . "value"))
|
|
(test-equal? parse-member-line
|
|
(parse-member-line "key value")
|
|
'(key . "value"))
|
|
(test-equal? parse-member-line
|
|
(parse-member-line "key value and some")
|
|
'(key . "value and some"))
|
|
(test-equal? parse-member-line
|
|
(parse-member-line "key value lot of spaces")
|
|
'(key . "value lot of spaces"))
|
|
))
|
|
|
|
)
|