Rename member-parser to brmember-parser.

src/brmember-parser.scm

@@ -0,0 +1,232 @@
+;;
+;; 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)
+	 brmember
+	 testing
+	 util-dict-list
+	 month
+	 period
+	 util-list
+	 configuration
+	 util-string
+	 util-parser)
+
+ ;; 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
+			      (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->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)
+	    (brmember-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 (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)))))
+
+ )