;;
;; command-line.scm
;;
;; Argument parsing on command-line with interpreter -- support.
;;
;; ISC License
;;
;; Copyright 2023-2025 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 command-line))

(module
 command-line
 (
  command-line

  command-line:parse-command-line
  command-line:print-options
  )

 (import scheme
	 (chicken base)
	 (chicken process-context)
	 (chicken format)
	 srfi-1
	 util-proc)

 ;; Consumes given number of arguments from the list and returns the
 ;; remainder of the list and a list of arguments consumed.
 (define (consume-args args num)
   (let loop ((args args)
	      (res '())
	      (num num))
     (if (= num 0)
	 (list args (reverse res))
	 (if (null? args)
	     (error 'consume-args "Not enough arguments" num)
	     (loop (cdr args)
		   (cons (car args) res)
		   (- num 1))))))

 ;; Gets command-line arguments after the "--" of csi (not useful when
 ;; compiled)
 (define (get-command-line-arguments . explicit-argv)
   (let* ((args (if (null? explicit-argv) (argv) explicit-argv))
	  (rargs (member "--" args)))
     (if rargs
	 (cdr rargs)
	 (cdr args))))

 ;; Performs the actual parsing based on specification.
 (define (command-line:parse-command-line specs+comments)
   (let ((specs (filter (lambda (s) (not (string? s))) specs+comments)))
     (let loop ((args (get-command-line-arguments)))
       (when (not (null? args))
	 (let* ((arg (car args))
		(specp (assoc arg specs)))
	   (when (not specp)
	     (error 'parse-command-line "Unknown argument" arg))
	   (let* ((proc (caddr specp))
		  (nargs (procedure-num-args proc))
		  (aargsl (consume-args (cdr args) nargs))
		  (args (car aargsl))
		  (aargs (cadr aargsl)))
	     (apply proc aargs)
	     (loop args)))))))

 ;; String representation of procedure arguments.
 (define (procedure->argstring proc)
   (let* ((args (procedure-arg-names proc))
	  (argss (sprintf "~A" args)))
     (substring
      (substring argss 0 (- (string-length argss) 1))
      1)))

 ;; Prints options descriptions.
 (define (command-line:print-options specs)
   (let* ((descrs (map (lambda (spec)
			 (if (string? spec)
			     spec
			     (list (car spec)
				   (procedure->argstring (caddr spec))
				   (cadr spec))))
		       specs))
	  (owidth (apply max (map (lambda (desc)
				    (if (string? desc)
					0
					(string-length (car desc))))
				  descrs)))
	  (awidth (apply max (map (lambda (desc)
				    (if (string? desc)
					0
					(string-length (cadr desc))))
				  descrs))))
     (let loop ((descrs descrs))
       (when (not (null? descrs))
	 (let ((desc (car descrs)))
	   (if (string? desc)
	       (print desc)
	       (let* ((opt (car desc))
		      (args (cadr desc))
		      (help (caddr desc)))
		 (print "  "
			opt
			(make-string (- owidth (string-length opt)) #\space)
			" "
			args
			(make-string (- awidth (string-length args)) #\space)
			"  "
			help)))
	   (loop (cdr descrs)))))))

 ;; Syntax for expanding various types of options.
 (define-syntax make-option
   (syntax-rules ()
     ((_ (opt (args ...) help body ...))
      (list (symbol->string 'opt)
	    help
	    (lambda (args ...) body ...)))
     ((_ str)
      str)))

 (define-syntax make-options
   (syntax-rules ()
     ((_ exp ...)
      (list (make-option exp) ...))))

 ;; Simple syntax wrapper for command-line arguments specification and
 ;; immediate parsing.
 (define-syntax command-line
   (syntax-rules ()
     ((_ print-help exps ...)
      (letrec ((specs (make-options exps ...))
	       (print-help (lambda ()
			     (command-line:print-options specs))))
	(command-line:parse-command-line specs)))))

 )