324 lines
11 KiB
Scheme
324 lines
11 KiB
Scheme
;;
|
|
;; member-file.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-file))
|
|
|
|
(module
|
|
member-file
|
|
(
|
|
member-file-error-symbol
|
|
load-member-file
|
|
member-file-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken string)
|
|
(chicken io)
|
|
(chicken irregex)
|
|
(chicken format)
|
|
(chicken random)
|
|
dictionary
|
|
month
|
|
period
|
|
testing
|
|
listing
|
|
ansi
|
|
configuration
|
|
progress)
|
|
|
|
;; Specification of known keys for various types of parsing
|
|
(define known-keys '(nick mail phone name born joined destroyed
|
|
;; mail2 ID email suspended tel ;; Unknown keys
|
|
))
|
|
(define start/stop-keys '(student suspend))
|
|
(define multi-keys '(card desfire credit))
|
|
|
|
;; Symbol used for error reporting in member file keys.
|
|
(define member-file-error-symbol
|
|
(string->symbol
|
|
(sprintf "error-symbol-~A"
|
|
(substring
|
|
(number->string (pseudo-random-real))
|
|
2))))
|
|
|
|
;; Derived keys
|
|
(define start/stop-keys-keys
|
|
(map
|
|
string->symbol
|
|
(flatten
|
|
(map
|
|
(lambda (key)
|
|
(let ((skey (symbol->string key)))
|
|
(list (string-intersperse (list skey "start") "")
|
|
(string-intersperse (list skey "stop") ""))))
|
|
start/stop-keys))))
|
|
|
|
;; All valid keys in one place for early validation
|
|
(define all-valid-keys
|
|
(append known-keys start/stop-keys-keys multi-keys))
|
|
|
|
;; Member File Parser: remove comments from line and return the result
|
|
(define (line-remove-comments l)
|
|
(let ((si (substring-index "#" l)))
|
|
(if si
|
|
(if (= si 0)
|
|
""
|
|
(car (string-chop l si)))
|
|
l)))
|
|
|
|
;; Reports error with highlighted source line(s), configured via the
|
|
;; *member-file-check-syntax* parameter.
|
|
(define (report-line-error file-name lines highlight message)
|
|
(when (not (eq? (*member-file-check-syntax*) 'quiet))
|
|
(progress-break
|
|
(print "Error in " file-name ": " message)
|
|
(newline)
|
|
(print-source-listing lines (list highlight)
|
|
(*member-file-context*)
|
|
a:error a:default
|
|
"" "" "...")
|
|
(newline)))
|
|
(if (eq? (*member-file-check-syntax*) 'error)
|
|
(exit 1)
|
|
(list member-file-error-symbol
|
|
(list highlight
|
|
message))))
|
|
|
|
;; Parses given key-value line. Key is up to first space, value is the
|
|
;; rest of the line. If the line doesn't contain anything, returns #f.
|
|
(define (split-member-line l . rest)
|
|
(let* ((file-name (if (not (null? rest)) (car rest) #f))
|
|
(rest1 (if (not (null? rest)) (cdr rest) '()))
|
|
(lines (if (not (null? rest1)) (car rest1) #f))
|
|
(rest2 (if (not (null? rest1)) (cdr rest1) '()))
|
|
(line-number (if (not (null? rest2)) (car rest2) #f))
|
|
(lc0 (irregex-replace "^[ \\t]*" (line-remove-comments l) ""))
|
|
(lc (irregex-replace "[ \\t]*$" lc0 "")))
|
|
(if (= (string-length lc) 0)
|
|
#f
|
|
(let ((dm (irregex-search (string->irregex "[ \\t]") lc)))
|
|
(if dm
|
|
(let* ((kei (irregex-match-start-index dm))
|
|
(skey (substring lc 0 kei))
|
|
(key (string->symbol skey))
|
|
(v0 (substring lc kei))
|
|
(val (irregex-replace "^[ \\t]*" v0 "")))
|
|
(if (member key all-valid-keys)
|
|
(list key val)
|
|
(if file-name
|
|
(report-line-error file-name lines line-number
|
|
(sprintf "Invalid key ~A" key))
|
|
(error 'split-member-line (sprintf "Invalid key ~A" key)))))
|
|
(if (member (string->symbol lc) all-valid-keys)
|
|
(if file-name
|
|
(report-line-error file-name lines line-number
|
|
(sprintf "No value for key ~A" lc))
|
|
(error 'split-member-line (sprintf "No value for key ~A" lc)))
|
|
(if file-name
|
|
(report-line-error file-name lines line-number
|
|
(sprintf "No value for invalid key ~A" lc))
|
|
(error 'split-member-line
|
|
(sprintf "No value for invalid key ~A" lc)))))))))
|
|
|
|
;; If given symbol represents start/stop symbol of either kind,
|
|
;; returns a list of the symbol representing the type and start/stop
|
|
;; symbol. It returns false otherwise.
|
|
(define (split-start/stop-symbol s)
|
|
(let* ((ss (symbol->string s))
|
|
(mstart (irregex-search (string->irregex "(start|stop)") ss)))
|
|
(if mstart
|
|
(let* ((istart (irregex-match-start-index mstart))
|
|
(bstring (substring ss 0 istart))
|
|
(sstring (substring ss istart)))
|
|
(list (string->symbol bstring)
|
|
(string->symbol sstring)))
|
|
#f)))
|
|
|
|
;; Processes member line adding given value v to the dictionary d
|
|
;; under key k. Special handling for start/stop symbols means given
|
|
;; value is prepended to given start/stop key (student/suspend) as
|
|
;; parsed month for later processing of student/suspend periods.
|
|
(define (process-member-line d k v line-number)
|
|
(let ((ss (split-start/stop-symbol k)))
|
|
(if ss
|
|
(let ((pk (car ss))
|
|
(pd (cadr ss))
|
|
(vl (string-split v " ")))
|
|
(if (null? vl) ; Should not happen - k/v parser already catches this
|
|
(error 'process-member-line "Missing date for start/stop symbol" k)
|
|
(let ((ds (car vl)))
|
|
(dict-set d pk
|
|
(cons (list pd (string->month ds) line-number)
|
|
(dict-ref d pk '()))))))
|
|
(case k
|
|
((card desfire credit) (dict-set d k (cons v (dict-ref d k '()))))
|
|
(else
|
|
(if (eq? k member-file-error-symbol)
|
|
(dict-set d k (cons v (dict-ref d k '())))
|
|
(dict-set d k v)))))))
|
|
|
|
;; Converts given key in member info dictionary from period markers
|
|
;; list to periods.
|
|
(define (convert-member-key:markers->periods m k)
|
|
(if (dict-has-key? m k)
|
|
(let* ((res (period-markers->periods
|
|
(sort-period-markers
|
|
(dict-ref m k '()))))
|
|
(ok? (car res))
|
|
(periods (cadr res))
|
|
(msg (caddr res))
|
|
(line-number (cadddr res))
|
|
(m1 (dict-set m k periods)))
|
|
(if ok?
|
|
m1
|
|
(dict-set m1 member-file-error-symbol
|
|
(cons (list line-number msg)
|
|
(dict-ref m1 member-file-error-symbol '())))))
|
|
m))
|
|
|
|
;; Converts all given keys using period-markers->periods.
|
|
(define (convert-member-keys:markers->periods m . ks)
|
|
(let loop ((m m)
|
|
(ks ks))
|
|
(if (null? ks)
|
|
m
|
|
(loop (convert-member-key:markers->periods m (car ks))
|
|
(cdr ks)))))
|
|
|
|
;; Credit values contain amount as the first token. Anything after
|
|
;; the first whitespace character is added as label of the credit
|
|
;; transaction. The result is cons of number and string.
|
|
(define (convert-member-value:credit v)
|
|
(let* ((va (string-split v))
|
|
(v0 (car va))
|
|
(vr (substring v (string-length v0))))
|
|
(cons (string->number v0)
|
|
vr)))
|
|
|
|
;; If member information dictionary contains 'credit, all elements of
|
|
;; the list under this key are converted to cons of number (amount)
|
|
;; and string (label / description).
|
|
(define (convert-member-key:credit m)
|
|
(if (dict-has-key? m 'credit)
|
|
(dict-set m 'credit
|
|
(reverse
|
|
(map convert-member-value:credit
|
|
(dict-ref m 'credit))))
|
|
m))
|
|
|
|
;; Converts the card id and any following string to card and label /
|
|
;; description string cons.
|
|
(define (convert-member-value:card v)
|
|
(let* ((va (string-split v))
|
|
(v0 (car va))
|
|
(vr (substring v (string-length v0))))
|
|
(cons v0 vr)))
|
|
|
|
;; Converts card ids to cons of two strings.
|
|
(define (convert-member-keys:card m . ks)
|
|
(let loop ((m m)
|
|
(ks ks))
|
|
(if (null? ks)
|
|
m
|
|
(let ((k (car ks)))
|
|
(loop (if (dict-has-key? m k)
|
|
(dict-set m k (map convert-member-value:card (dict-ref m k)))
|
|
m)
|
|
(cdr ks))))))
|
|
|
|
;; Converts given key to month if it is a string. Leaves untouched
|
|
;; otherwise.
|
|
(define (convert-member-key:month m k)
|
|
(let ((v (dict-ref m k)))
|
|
(if (string? v)
|
|
(dict-set m k (string->month v))
|
|
m)))
|
|
|
|
;; Adds file-name and lines information to the error key.
|
|
(define (convert-member-key:error m esym lines file-name)
|
|
(dict-set m esym
|
|
(cons file-name
|
|
(cons lines
|
|
(dict-ref m esym '())))))
|
|
|
|
;; All conversions in one place, including error reporting.
|
|
(define (convert-member-keys m lines file-name)
|
|
(convert-member-key:error
|
|
(convert-member-key:month
|
|
(convert-member-keys:card
|
|
(convert-member-key:credit
|
|
(convert-member-keys:markers->periods m 'suspend 'student))
|
|
'card 'desfire)
|
|
'joined)
|
|
member-file-error-symbol lines file-name))
|
|
|
|
;; Fills-in the defaults
|
|
(define (make-default-member-info)
|
|
(dict-set
|
|
(make-dict)
|
|
'joined
|
|
(*member-default-joined*)))
|
|
|
|
;; Processes all lines and returns a dictionary representing given
|
|
;; member.
|
|
(define (parse-member-lines lines file-name)
|
|
(let loop ((ls lines)
|
|
(r (make-default-member-info))
|
|
(line-number 1))
|
|
(if (null? ls)
|
|
(convert-member-keys r lines file-name)
|
|
(let ((p (split-member-line (car ls) file-name lines line-number)))
|
|
(loop (cdr ls)
|
|
(if p
|
|
(process-member-line r (car p) (cadr p) line-number)
|
|
r)
|
|
(+ line-number 1))))))
|
|
|
|
;; Loads lines from given file and parses them.
|
|
(define (load-member-file ffn)
|
|
(let* ((f (open-input-file ffn))
|
|
(ls (read-lines f)))
|
|
(parse-member-lines ls ffn)))
|
|
|
|
;; Performs self-tests of the member-file module.
|
|
(define (member-file-tests!)
|
|
(run-tests
|
|
member-file
|
|
(test-equal? line-remove-comments (line-remove-comments "# all comment") "")
|
|
(test-equal? line-remove-comments (line-remove-comments "") "")
|
|
(test-equal? line-remove-comments (line-remove-comments "test # comment") "test ")
|
|
(test-equal? line-remove-comments (line-remove-comments "test") "test")
|
|
(test-equal? split-member-line (split-member-line "nick value") '(nick "value"))
|
|
(test-equal? split-member-line (split-member-line " nick value") '(nick "value"))
|
|
(test-equal? split-member-line (split-member-line " nick value ") '(nick "value"))
|
|
(test-equal? split-member-line (split-member-line " nick value1 value2 ") '(nick "value1 value2"))
|
|
(test-exn split-member-line (split-member-line "key value"))
|
|
(test-equal? split-start/stop-symbol (split-start/stop-symbol 'suspendstart) '(suspend start))
|
|
(test-equal? split-start/stop-symbol (split-start/stop-symbol 'teststop) '(test stop))
|
|
(test-false split-start/stop-symbol (split-start/stop-symbol 'normalkey))
|
|
))
|
|
|
|
)
|