diff --git a/member-file.scm b/member-file.scm index 6966cd5..f190d61 100644 --- a/member-file.scm +++ b/member-file.scm @@ -34,16 +34,38 @@ (chicken base) (chicken string) (chicken io) + (chicken irregex) + (chicken format) dictionary month period - testing) + testing + listing) ;; Specification of known keys for various types of parsing (define known-keys '(nick mail phone name born joined)) (define start/stop-keys '(student suspend)) (define multi-keys '(card desfire credit)) + ;; Configuration of error reporting + (define *member-file-context* (make-parameter 3)) + + ;; 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))) @@ -53,14 +75,47 @@ (car (string-chop l si))) l))) + (define (report-line-error file-name lines highlights message) + (print "Error in " file-name ": " message) + (newline) + (print-source-listing lines highlights (*member-file-context*) "\x1b[31;1m" "\x1b[0m" "" "" "...") + (exit 1)) + ;; 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 (parse-member-line l) - (let ((sp (string-split (line-remove-comments l) " "))) - (and sp - (not (null? sp)) - (list (string->symbol (car sp)) - (string-intersperse (cdr sp)))))) + (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]*" 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 (list 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 (list 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 (list 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 @@ -119,13 +174,13 @@ ;; Processes all lines and returns a dictionary representing given ;; member. - (define (parse-member-lines ls) - (let loop ((ls ls) + (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:markers->periods r 'suspend 'student) - (let ((p (parse-member-line (car ls)))) + (let ((p (split-member-line (car ls) file-name lines line-number))) (loop (cdr ls) (if p (apply process-member-line r p) @@ -136,7 +191,7 @@ (define (load-member-file ffn) (let* ((f (open-input-file ffn)) (ls (read-lines f)) - (md (parse-member-lines ls))) + (md (parse-member-lines ls ffn))) (display ".") md)) @@ -148,6 +203,11 @@ (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")) )) )