(module easy-args
  ((define-arguments process-arguments make-option make-option-parameter)
   unmatched-arguments invalid-argument-handler)
  (import scheme chicken extras)
  (use 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)
          (format "~a: ~a for option '~a'\n" (program-name) msg k))
        (exit 1))))

  ;; Internal. Creates a parameter
  ;; for the given value and guard.
  (define (make-option-parameter . spec)
    (let-optionals spec ((value #f) (guard #f))
      (apply make-parameter
        value
        (if guard
          (list guard)
          '()))))

  ;; Internal. Creates a srfi-37 record
  ;; for the given parameter object,
  ;; name list & default value.
  (define (make-option parameter names . spec)
    (let ((r (invalid-argument-handler)))
      (let-optionals spec ((value #f) (guard #f))
        (option (map (lambda (name)
                       (if (> (string-length name) 1)
                         (string-delete #\* name)
                         (string-ref name 0)))
                     (map symbol->string names))
                (and 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 . option-list)
    (let ((unmatched '()))
      (command-line-arguments
        (args-fold
          (command-line-arguments)
          option-list
          (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> <alias> ...) <value/guard> ...) ...))
       (begin (define <name> (make-option-parameter <value/guard> ...)) ...
              (void (process-arguments (make-option <name> '(<name> <alias> ...) <value/guard> ...) ...))))
      ((_ "aux" (acc ...) ((<name> <alias> ...) <value/guard> ...) tail ...)
       (define-arguments "aux" (((<name> <alias> ...) <value/guard> ...) acc ...) tail ...))
      ((_ "aux" (acc ...) (<name> <value/guard> ...) tail ...)
       (define-arguments "aux" (((<name>) <value/guard> ...) acc ...) tail ...))
      ((_ tail ...)
       (define-arguments "aux" () tail ...)))))