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

(module
 command-line
 (command-line
  command-line:parse-command-line
  command-line:print-options
  command-line-tests!)

 (import scheme
	 (chicken base)
	 (chicken process-context)
	 (chicken format)
	 testing)

 ;; 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)
   (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))
		(info (procedure-information proc))
		(nargs (- (length info) 1))
		(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* ((info (procedure-information proc))
	  (args (cdr info))
	  (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)
			 (list (car spec)
			       (procedure->argstring (caddr spec))
			       (cadr spec)))
		       specs))
	  (owidth (apply max (map (lambda (desc)
				    (string-length (car desc)))
				  descrs)))
	  (awidth (apply max (map (lambda (desc)
				    (string-length (cadr desc)))
				  descrs))))
     (let loop ((descrs descrs))
       (when (not (null? descrs))
	 (let* ((desc (car descrs))
		(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 help proc)
      (list (symbol->string 'opt) help proc))
     ((_ opt (args ...) help body ...)
      (list (symbol->string 'opt)
	    help
	    (lambda (args ...) body ...)))))

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

 ;; Performs self-tests of the command-line module
 (define (command-line-tests!)
   (run-tests
    command-line
    (test-exn consume-args (consume-args '(1 2 3) 4))
    (test-equal? consume-args (consume-args '(1 2 3 4) 2) '((3 4) (1 2)))
    (test-equal? get-command-line-arguments (get-command-line-arguments 1 2 3) '(2 3))
    (test-equal? get-command-line-arguments (get-command-line-arguments 1 "--" 2 3) '(2 3))
    (test-equal? procedure->argstring (procedure->argstring (lambda (x . y) 1)) "x . y")
    (test-equal? procedure->argstring (procedure->argstring (lambda (x) 1)) "x")
    (test-equal? procedure->argstring (procedure->argstring (lambda () 1)) "")
    ))

 )