;;
;; 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)
	 member-record
	 testing
	 dictionary
	 month
	 period
	 utils
	 configuration)

 ;; 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
			      (member-record-sub-prepend
			       mr output kind
			       (list marker month (cdr value) comment))
			      (member-record-add-highlight
			       mr (cdr value) "Invalid month specification" 3 'error))))
		      mr value))
	     (member-record-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 (member-record-sub-set mr output key periods)))
	      (if ok?
		  mr1
		  (member-record-add-highlight mr1 line-number msg 3 'error))))
	   ((card desfire)
	    (member-record-sub-set mr output key
				   (map
				    (lambda (rec)
				      (string-first+rest (car rec)))
				    value)))
	   ((credit)
	    (member-record-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 (member-record-sub-set mr output key (car value))))
	      (if (irregex-search (irregex "[ \\t]" 'u) (car value))
		  (member-record-add-highlight
		   mr0 (cdr value) "Whitespace not allowed in nick" 3 'error)
		  mr0)))
	   (else
	    (member-record-sub-set mr output key (car value))))))))

 ;; Pass 4: Final checks - add defaults
 (define (member-schema-finalize mr)
   (apply
    member-record-sub-ensure
    mr 'info
    (join (map (lambda (mk) (list mk #f)) mandatory-keys))))

 ;; 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 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 known-multikeys)
		   (loop (cdr parsed)
			 mr
			 (dict-set processed key (cons (cons value number)
						       (dict-ref processed key '()))))
		   (loop (cdr parsed)
			 (if (member key ignored-keys)
			     mr
			     (member-record-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 (dict-keys input))
	      (mr (dict-set mr output (make-dict))))
     (if (null? keys)
	 mr
	 (let ((key (car keys)))
	   (loop (cdr keys)
		 (pass-proc mr output key
			    (dict-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 (dict-ref mr prev-name) pass-proc)))))))

 ;; 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)))
     (member-schema-finalize
      (interpret-member-file
       (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"))
    ))

 )