;;
;; 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)
	 member2-record
	 testing
	 dictionary)

 ;; TODO: move to separate schema module
 (define member-schema-known-keys '(nick mail phone name born joined destroyed))
 (define member-schema-known-multikeys '(card desfire credit studentstart studentstop suspendstart suspendstop))

 ;; 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 member-schema-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 member-schema-known-multikeys)
		   (loop (cdr parsed)
			 mr
			 (dict-set processed key (cons (cons value number)
						       (dict-ref processed key '()))))
		   (loop (cdr parsed)
			 (member-record-add-highlight mr number "Unknown key" 2 'warning)
			 processed)))))))

 ;; 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)))
     (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"))
    ))

 )

(import member-parser)

(member-parser-tests!)
(print (load-member-file (make-member-record "joe" "members/joe" '())))