Remove old member-file.
This commit is contained in:
parent
da539a03fd
commit
9ffe65ee0c
1 changed files with 0 additions and 368 deletions
|
|
@ -1,368 +0,0 @@
|
|||
;;
|
||||
;; 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))
|
||||
(define validated-keys '(nick))
|
||||
|
||||
;; 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 (if (member k validated-keys)
|
||||
(cons v line-number)
|
||||
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
|
||||
(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 (irregex-replace
|
||||
(irregex "^ *" 'u)
|
||||
(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 '())))))
|
||||
|
||||
;; Check actual key error
|
||||
(define (check-member-key-error key v)
|
||||
(case key
|
||||
((nick)
|
||||
(if (irregex-search (irregex " " 'u) v)
|
||||
"Space in nick!"
|
||||
#f))
|
||||
(else
|
||||
#f)))
|
||||
|
||||
;; Adds error to the highlights
|
||||
(define (add-member-error mr ln msg)
|
||||
(dict-set mr member-file-error-symbol
|
||||
(cons (list ln msg)
|
||||
(dict-ref mr member-file-error-symbol '()))))
|
||||
|
||||
;; Performs actual validation, optionally adding error to the list
|
||||
(define (validate-member-key m key v line-number)
|
||||
(let ((res (check-member-key-error key v)))
|
||||
(if res
|
||||
(add-member-error m line-number res)
|
||||
m)))
|
||||
|
||||
;; Gets cons of nick and line number and if validation fails, adds
|
||||
;; error to the error key.
|
||||
(define (convert-member-key:validation m)
|
||||
(let loop ((keys validated-keys)
|
||||
(m m))
|
||||
(if (null? keys)
|
||||
m
|
||||
(let ((key (car keys)))
|
||||
(loop (cdr keys)
|
||||
(if (dict-has-key? m key)
|
||||
(let ((v (dict-ref m key)))
|
||||
(validate-member-key (dict-set m key (car v))
|
||||
key (car v) (cdr v)))
|
||||
m))))))
|
||||
|
||||
;; All conversions in one place, including error reporting.
|
||||
(define (convert-member-keys m lines file-name)
|
||||
(convert-member-key:error
|
||||
(convert-member-key:validation
|
||||
(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))
|
||||
))
|
||||
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue