;;
;; 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)
	 (chicken string)
	 brmember
	 testing
	 util-dict-list
	 cal-month
	 cal-period
	 util-list
	 configuration
	 util-string
	 util-parser
	 cal-day)

 ;; 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->cal-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->cal-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)
	    (let loop ((mr mr)
		       (src-credits value)
		       (credits '()))
	      (if (null? src-credits)
		  (brmember-sub-set mr output key credits)
		  (let* ((rec (caar src-credits))
			 (line-number (cdar src-credits))
			 (fr (string-first+rest rec))
			 (amt (string->number (car fr)))
			 (msg (cdr fr))
			 (mlst (string-split msg))
			 (mon (if (null? mlst)
				  #f
				  (parse-cal-day/month (car mlst))))
			 (rmsg (if mon
				   (string-intersperse (cdr mlst) " ")
				   msg)))
		    (loop (if mon
			      mr
			      (brmember-add-highlight mr line-number
						      "missing date or month information"
						      3
						      'warning))
			  (cdr src-credits)
			  (cons (list amt mon rmsg)
				credits))))))
	   ((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)))))

 )