;;
;; member-file.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-file))

(module
 member-file
 (
  *member-file-context*
  *member-file-check-syntax*
  *member-default-joined*
  load-member-file
  member-file-tests!
  )

 (import scheme
	 (chicken base)
	 (chicken string)
	 (chicken io)
	 (chicken irregex)
	 (chicken format)
	 dictionary
	 month
	 period
	 testing
	 listing
	 ansi)

 ;; Specification of known keys for various types of parsing
 (define known-keys '(nick mail phone name born joined destroyed
			   ;; mail2 ID email suspended tel ;; Unknown keys
			   ))
 (define start/stop-keys '(student suspend))
 (define multi-keys '(card desfire credit))

 ;; Configuration of error reporting
 (define *member-file-context* (make-parameter 3))

 ;; Tolerance to formal errors (invalid key or key without value):
 ;;  'error - show source and exits with error
 ;;  'warning - show source and error, continue
 ;;  'quiet - ignore
 (define *member-file-check-syntax* (make-parameter 'error))

 (define *member-default-joined* (make-parameter (make-month 2015 1)))

 ;; 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)))
     (if si
	 (if (= si 0)
	     ""
	     (car (string-chop l si)))
	 l)))

 ;; Reports error with highlighted source line(s), configured via the
 ;; *member-file-check-syntax* parameter.
 (define (report-line-error file-name lines highlights message)
   (when (not (eq? (*member-file-check-syntax*) 'quiet))
     (print "Error in " file-name ": " message)
     (newline)
     (print-source-listing lines highlights
			   (*member-file-context*)
			   a:error a:default
			   "" "" "..."))
   (if (eq? (*member-file-check-syntax*) 'error)
       (exit 1)
       #f))

 ;; 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 (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]*" (line-remove-comments 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
 ;; symbol. It returns false otherwise.
 (define (split-start/stop-symbol s)
   (let* ((ss (symbol->string s))
	  (mstart (irregex-search (string->irregex "(start|stop)") ss)))
     (if mstart
	 (let* ((istart (irregex-match-start-index mstart))
		(bstring (substring ss 0 istart))
		(sstring (substring ss istart)))
	   (list (string->symbol bstring)
		 (string->symbol sstring)))
	 #f)))

 ;; Processes member line adding given value v to the dictionary d
 ;; under key k. Special handling for start/stop symbols means given
 ;; value is prepended to given start/stop key (student/suspend) as
 ;; parsed month for later processing of student/suspend periods.
 (define (process-member-line d k v)
   (let ((ss (split-start/stop-symbol k)))
     (if ss
	 (let ((pk (car ss))
	       (pd (cadr ss))
	       (vl (string-split v " ")))
	   (if (null? vl)
	       (error 'process-member-line "Missing date for start/stop symbol" k)
	       (let ((ds (car vl)))
		 (dict-set d pk
			   (cons (cons pd (string->month ds))
				 (dict-ref d pk '()))))))
	 (case k
	   ((card desfire credit) (dict-set d k (cons v (dict-ref d k '()))))
	   (else
	    (dict-set d k v))))))

 ;; Converts given key in member info dictionary from period markers
 ;; list to periods.
 (define (convert-member-key:markers->periods m k)
   (if (dict-has-key? m k)
       (dict-set m k
		 (period-markers->periods
		  (sort-period-markers
		   (dict-ref m k '()))))
       m))

 ;; Converts all given keys using period-markers->periods.
 (define (convert-member-keys:markers->periods m . ks)
   (let loop ((m m)
	      (ks ks))
     (if (null? ks)
	 m
	 (loop (convert-member-key:markers->periods m (car ks))
	       (cdr ks)))))

 ;; Credit values contain amount as the first token. Anything after
 ;; the first whitespace character is added as label of the credit
 ;; transaction. The result is cons of number and string.
 (define (convert-member-value:credit v)
   (let* ((va (string-split v))
	  (v0 (car va))
	  (vr (substring v (string-length v0))))
     (cons (string->number v0)
	   vr)))

 ;; If member information dictionary contains 'credit, all elements of
 ;; the list under this key are converted to cons of number (amount)
 ;; and string (label / description).
 (define (convert-member-key:credit m)
   (if (dict-has-key? m 'credit)
       (dict-set m 'credit
		 (reverse
		  (map convert-member-value:credit
		       (dict-ref m 'credit))))
       m))

 ;; Converts the card id and any following string to card and label /
 ;; description string cons.
 (define (convert-member-value:card v)
   (let* ((va (string-split v))
	  (v0 (car va))
	  (vr (substring v (string-length v0))))
     (cons v0 vr)))

 ;; Converts card ids to cons of two strings.
 (define (convert-member-keys:card m . ks)
   (let loop ((m m)
	      (ks ks))
     (if (null? ks)
	 m
	 (let ((k (car ks)))
	   (loop (if (dict-has-key? m k)
		     (dict-set m k (map convert-member-value:card (dict-ref m k)))
		     m)
		 (cdr ks))))))

 ;; Converts given key to month if it is a string. Leaves untouched
 ;; otherwise.
 (define (convert-member-key:month m k)
   (let ((v (dict-ref m k)))
     (if (string? v)
	 (dict-set m k (string->month v))
	 m)))

 ;; All conversions in one place
 (define (convert-member-keys m)
   (convert-member-key:month
    (convert-member-keys:card
     (convert-member-key:credit
      (convert-member-keys:markers->periods m 'suspend 'student))
     'card 'desfire)
    'joined))

 ;; Fills-in the defaults
 (define (make-default-member-info)
   (dict-set
    (make-dict)
    'joined
    (*member-default-joined*)))

 ;; Processes all lines and returns a dictionary representing given
 ;; member. 
 (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 r)
	 (let ((p (split-member-line (car ls) file-name lines line-number)))
	   (loop (cdr ls)
		 (if p
		     (apply process-member-line r p)
		     r)
		 (+ line-number 1))))))

 ;; Loads lines from given file and parses them.
 (define (load-member-file ffn)
   (let* ((f (open-input-file ffn))
	  (ls (read-lines f)))
     (parse-member-lines ls ffn)))

 ;; Performs self-tests of the member-file module.
 (define (member-file-tests!)
   (run-tests
    member-file
    (test-equal? line-remove-comments (line-remove-comments "# all comment") "")
    (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"))
    (test-equal? split-start/stop-symbol (split-start/stop-symbol 'suspendstart) '(suspend start))
    (test-equal? split-start/stop-symbol (split-start/stop-symbol 'teststop) '(test stop))
    (test-false  split-start/stop-symbol (split-start/stop-symbol 'normalkey))
    ))

 )