(module args
	
	(;; Option lists
	 args:parse
	 args:help-options
	 args:ignore-unrecognized-options
	 args:accept-unrecognized-options
	 make-args:option
	 ;; Usage printing
	 args:usage
	 args:width
	 args:separator
	 args:indent

	 args:make-option)

	(import scheme chicken extras)

	(require-extension srfi-1 srfi-13 srfi-37)


;;; macro: (args:make-option (OPTION-NAME ...) ARG-TYPE [BODY])
;; Make an args:option record, suitable for passing to args:parse.
;;
;; OPTION-NAME ... is a sequence of short or long option names.  They must be literal
;; symbols; single-character symbols become short options, and longer symbols become
;; long options.  So (args:make-option (c cookie) <...>) specifies a short option -c
;; and long option --cookie.  Underneath, (c cookie) becomes '(#\c "cookie"), as
;; expected by SRFI 37's OPTION.
;; 
;; ARG-DATA is either a pair (ARG-TYPE ARG-NAME) or a plain keyword ARG-TYPE.
;; ARG-TYPE is a keyword that specifies whether the option takes an argument:
;;    #:required   Argument is required
;;    #:optional   Argument is optional
;;    #:none       Does not take an argument (actually, any other value than
;;                 #:required or #:optional is interpreted as #:none)
;; ARG-NAME, if provided, is a string specifying the name of the argument.
;; This name is used in the help text produced by args:usage.
;;
;; BODY is an optional sequence of statements executed when this option is encountered.
;; Behind the scenes, BODY is wrapped in code which adds the current option and its
;; argument to the final options alist.  So, simply leave BODY blank and options
;; will be collected for you.  BODY is an option-processor as defined in SRFI 37,
;; and has access to the variables OPT (the current #<option>), NAME (the option name)
;; and ARG (argument value or #f).

(define-record args:option option arg-name docstring)

;;; procedure: (args:parse ARGS OPTIONS-LIST [OPTIONALS])
;; [chicken-specific dependencies: FPRINTF; GET-KEYWORD; ARGV]

;; Parse ARGS, a list of command-line arguments given as strings,
;; and return two values: an alist of option names (symbols) and their values,
;; and a list of operands (non-option arguments).

;; Operands are returned in order, but options are returned in reverse order.
;; Duplicate options are retained in the options alist, so this lets ASSQ
;; find the -last- occurrence of any duplicate option on the command line.
;; A (name . value) pair is added for each alias of every option found,
;; so any alias is a valid lookup key.

;; OPTIONS-LIST is a list of accepted options, each created by
;; args:make-option.
;;
;; OPTIONALS is an optional sequence of keywords and values:
;;   #:operand-proc PROCEDURE   -- calls PROCEDURE for each operand
;;                                 with arguments OPERAND OPTIONS OPERANDS;
;;                                 returns next seed (values OPTIONS OPERANDS)
;;   #:unrecognized-proc PROCEDURE -- calls PROCEDURE for each unrecognized option
;;                                    with arguments OPTION NAME ARG OPTIONS OPERANDS
;; The default operand-proc is a no-op, and the default unrecognized-proc
;; issues an error message and calls the help option's processor.
;; See the args-fold documentation for usage information and an explanation
;; of the procedure arguments; OPTIONS and OPERANDS are seed values.

;; Two prefabricated unrecognized-procs are provided:
;;    args:ignore-unrecognized-options
;;    args:accept-unrecognized-options

(define (find-named-option name opts)
  (find (lambda (o)
          (member name (option-names (args:option-option o))))
        opts))

(define (find-help-option opts)
  (any (lambda (n) (find-named-option n opts))
       (args:help-options)))

;;; parameter: args:help-options
;; List of option names (strings or single characters, as in SRFI 37)
;; to be considered 'help' options, in order of preference.  args:parse
;; uses this to select a help option from the option list it is passed.
;; This is currently used only for unrecognized options, for which the
;; help option is automatically invoked.

(define args:help-options
  (make-parameter '("help" #\h #\?)))

(define (args:parse args options-list . optionals)
  (let ((help-option (find-help-option options-list)))
    (receive (options operands)
        (args-fold args
                   (map (lambda (x) (args:option-option x))
                        options-list)
                   (get-keyword #:unrecognized-proc optionals
                                (lambda ()  ; thunk
                                  ;; Default: print unrecognized option and execute help procedure,
                                  ;; if a help option was provided.
                                  (lambda (opt name arg options operands)
                                    (fprintf (current-error-port)
                                             "~A: unrecognized option: ~A\n"
                                             (car (argv)) name)
                                    (if help-option
                                        ((option-processor (args:option-option help-option))
                                         opt name arg options operands)
                                        (exit 1)))))
                   ;; modify the operands list for operands
                   (get-keyword #:operand-proc optionals
                                (lambda () (lambda (operand options operands)
                                        (values options
                                                (cons operand operands)))))
                   '()     ;; seed 1: options alist
                   '())    ;; seed 2: operands list
      (values options (reverse operands)))))

;;; Prefabbed unrecognized option procedures
;; Suitable for use as the #:unrecognized-proc in args:parse.

;; Silently ignore unrecognized options, and omit from the options alist.
(define args:ignore-unrecognized-options
  (lambda (o n x options operands)
    (values options operands)))

;; Silently add unrecognized options to the options alist.
(define args:accept-unrecognized-options
  (lambda (o n x options operands)
    (values (cons (cons (string->symbol (if (char? n) (string n) n))
                        x)
                  options)
            operands)))

;;; Usage handling

;; Change #\c => "-c" and "cookie" to "--cookie".
(define (dashify x)
  (if (char? x)
      (string #\- x)
      (string-append "--" x)))
 
;; O is an args:option
;; Join together option names in O with commas, and append the
;; argument type and name
(define (spaces n)
  (let loop ((ls '()) (n n))
    (if (<= n 0)
        (list->string ls)
        (loop (cons #\space ls)
              (- n 1)))))

(define (commify o)   ;; more at home in Stalin?
  (let ((arg-type (lambda (args:o o-name)
                    (let* ((arg-name (args:option-arg-name args:o))
                           (o (args:option-option args:o)))
                      (cond ((option-required-arg? o)
                             (string-append (if (char? o-name)
                                                " " "=")
                                            arg-name))
                            ((option-optional-arg? o)
                             (string-append (if (char? o-name)
                                                " [" "[=")
                                            arg-name "]"))
                            (else ""))))))

    (let loop ((accum #f)
               (names (option-names (args:option-option o))))
      (if (null? names)
          accum
          (let* ((name (car names))
                 (may-be-arg
                  (if (null? (cdr names))
                      (arg-type o name)
                      "")))
            (loop (string-append (or accum
                                     ;; Must deal with first one specially
                                     (if (string? name)
                                         (spaces (+ 2 (string-length (args:separator))))
                                         ""))
                                 (if accum (args:separator) "")
                                 (dashify name) may-be-arg)
                  (cdr names)))))))

;;; parameter: args:width
;; We don't auto-format the left column (the option keys) based on the length of the longest
;; option, but you can override it manually.
;;
;; Example: (parameterize ((args:width 40)) (args:usage opts))
(define args:width (make-parameter 25))
;;; parameter: args:separator
;; The separator used between options.  Default: ", "
;; Example: (parameterize ((args:separator " ")) (args:usage opts))
(define args:separator (make-parameter ", "))
(define args:indent (make-parameter 1))

;; O is an args:option
(define (usage-line o)
  (let ((option-string (commify o)))
    (string-append (spaces (args:indent))
                   (string-pad-right option-string (args:width))
                   (args:option-docstring o) "\n")))

;;; procedure: (args:usage OPTION-LIST)
;; Generate a formatted list of options from OPTION-LIST,
;; and return a string suitable for embedding into help text.
;; The single string consists of multiple lines, with a newline
;; at the end of each line.  Thus, a typical use would be
;; (print (args:usage opts)).
(define (args:usage opts)
  (apply string-append (map usage-line opts)))


;;; macro: (args:make-option (OPTION-NAME ...) ARG-DATA [BODY])

;; OPTION-NAME ... is a sequence of short or long option names.  They must be literal
;; symbols; single-character symbols become short options, and longer symbols become
;; long options.  So (args:make-option (c cookie) <...>) specifies a short option -c
;; and long option --cookie.  Underneath, (c cookie) becomes '(#\c "cookie"), as
;; expected by SRFI 37's OPTION.
;; 
;; ARG-DATA is either a pair (ARG-TYPE ARG-NAME) or a plain keyword ARG-TYPE.
;; ARG-TYPE is a keyword that specifies whether the option takes an argument:
;;    #:required   Argument is required
;;    #:optional   Argument is optional
;;    #:none       Does not take an argument (actually, any other value than
;;                 #:required or #:optional is interpreted as #:none)
;; ARG-NAME, if provided, is a string specifying the name of the argument.
;; This name is used in the help text produced by args:usage.
;;
;; BODY is an optional sequence of statements executed when this option is encountered.
;; Behind the scenes, BODY is wrapped in code which adds the current option and its
;; argument to the final options alist.  So, simply leave BODY blank and options
;; will be collected for you.  BODY is an option-processor as defined in SRFI 37,
;; and has access to the variables OPT (the current #<option>), NAME (the option name)
;; and ARG (argument value or #f).

(define-syntax args:make-option
  (lambda (x r c)
    (let ((names     (cadr x))
	  (arg-data  (caddr x))
	  (docstring (cadddr x))
	  (body      (cddddr x))
	  (%lambda  (r 'lambda))
	  (%begin   (r 'begin))
	  (%values  (r 'values))
	  (%if      (r 'if))
	  (%and     (r 'and))
	  (%not      (r 'not))
	  (%eq?     (r 'eq?))
	  (%car      (r 'car))
	  (%cons     (r 'cons))
	  (%append   (r 'append))
	  (%map     (r 'map))
	  (argv     (r 'argv))
	  (fprintf  (r 'fprintf))
	  (current-error-port    (r 'current-error-port))
	  (option  (r 'option))
	  (make-args:option  (r 'make-args:option))
	  )

      (let* ((srfi37-names (map (lambda (name)
				  (let ((str (->string name)))
				    (if (= (string-length str) 1)
					(string-ref str 0)
					str)))
				names))
	     (arg-name (if (pair? arg-data) (cadr arg-data) "ARG"))
	     (arg-type (if (pair? arg-data) (car arg-data) arg-data)))

	`(,make-args:option
	  (,option ',srfi37-names
		  ,(eq? arg-type #:required)
		  ,(eq? arg-type #:optional)
		  (,%lambda (opt name arg options operands)
		    (,%if (,%and (,%not arg) (,%eq? ,arg-type #:required))
			(,%begin
			  (,fprintf (,current-error-port)
				   "~A: option ~A requires an argument\n"
				   (,%car (,argv)) name)
			  (,%values options operands))
			(,%begin
			  ,@body
			  (,%values (,%append (,%map (,%lambda (n) (,%cons n arg))
						     ',names)
					      options)
				    operands)))))
	  ;;(values (cons (cons name arg) options) operands)))
	  ,arg-name
	  ,docstring)))))

)