;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This software was written by Evan Hanson, subsequently deprecated,
;;; and hereby placed into the Public Domain. All warranties are
;;; disclaimed.
;;;

(module easy-args
  ((define-arguments process-arguments make-option)
   invalid-argument-handler
   unmatched-arguments)
  (import scheme chicken)
  (use extras srfi-13 srfi-37)

  ;; Return an alist of arguments unhandled by define-arguments.
  (define unmatched-arguments (lambda () '()))

  ;; Handler to be used when an invalid option is encountered.
  ;; By default, exits the program with a simple error message.
  (define invalid-argument-handler
    (make-parameter
     (lambda (msg k v)
       (fprintf (current-error-port)
                "~a: ~a for option '~a'\n"
                (program-name) msg k)
       (exit 1))))

  ;; Internal. Creates a srfi-37 record for the given parameter object,
  ;; name list and default value.
  (define (make-option parameter names #!optional value guard)
    (let ((r (invalid-argument-handler)))
      (option (map (lambda (name)
                     (if (> (string-length name) 1)
                         (string-delete #\* name)
                         (string-ref name 0)))
                   (map symbol->string names))
              value
              #f
              (lambda (o k v rest)
                (parameter
                 (cond ((string? value)
                        (or v (r "value required" k v)))
                       ((boolean? value)
                        (or (and (not v) #t)
                            (r "unexpected value" k v)))
                       ((symbol? value)
                        (or (and v (string->symbol v))
                            (r "value required" k v)))
                       ((number? value)
                        (or (and v (string->number v))
                            (r "numeric value required" k v)))
                       (else
                        (error 'define-arguments
                               "invalid default value" k v))))
                rest))))

  ;; Internal. Process (command-line-arguments) against the given list
  ;; of options, removing matched arguments and accumulating the rest
  ;; into the unmatched-arguments procedure.
  (define (process-arguments . options)
    (let ((unmatched '()))
      (command-line-arguments
       (args-fold (command-line-arguments)
                  options
                  (lambda (o k v rest)
                    (set! unmatched
                      (cons (cons k (or v #t)) unmatched))
                    rest)
                  cons
                  '()))
      (let ((lst (reverse unmatched)))
        (set! unmatched-arguments (lambda () lst)))))

  (define-syntax define-arguments
    (syntax-rules ()
      ((_ "aux" (((<name> . <names>) . <args>) ...))
       (begin
         (define <name> (make-parameter . <args>))
         ...
         (process-arguments (make-option <name> '(<name> . <names>) . <args>) ...)))
      ((_ "aux" acc ((<name> . <names>)) . tail)
       (define-arguments "aux" (((<name> . <names>) #f) . acc) . tail))
      ((_ "aux" acc ((<name> . <names>) . <args>) . tail)
       (define-arguments "aux" (((<name> . <names>) . <args>) . acc) . tail))
      ((_ "aux" acc (<name> . <args>) . tail)
       (define-arguments "aux" acc ((<name>) . <args>) . tail))
      ((_ . tail)
       (define-arguments "aux" () . tail)))))