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

(use easy-args srfi-13 srfi-78)

(define-syntax test-arguments
  (syntax-rules (=> =/=>)
    ((_ <a> <e> ... => <r>)
     (parameterize ((command-line-arguments <a>))
       (check (begin <e> ...) => <r>)))
    ((_ <a> <e> ... =/=> <r>)
     (test-arguments <a>
       (call-with-current-continuation
         (lambda (k)
           (invalid-argument-handler (compose k car list))
           <e> ...)) => <r>))))

;; Without arguments.
(test-arguments '()
  (define-arguments (bool) (num 1) (sym 'foo) (str "bar"))
  (list (bool) (num) (sym) (str)) => '(#f 1 foo "bar"))

;; With arguments, general form.
(test-arguments '("--num" "2" "--sym" "baz" "--str=qux")
  (define-arguments ((bool)) ((num) 1) ((sym) 'foo) ((str) "bar"))
  (list (bool) (num) (sym) (str)) => '(#f 2 baz "qux"))

;; Single-character option flags.
(test-arguments '("-bn2" "-m" "baz" "-rqux")
  (define-arguments (b) (n 1) (m 'foo) (r "bar"))
  (list (b) (n) (m) (r)) => '(#t 2 baz "qux"))

;; Repeated arguments.
(test-arguments '("--num" "2" "--number" "3")
  (define-arguments ((num number n) 1))
  (num) => 3)

;; Strip earmuffs from parameter names.
(test-arguments '("--earmuffs" "bar")
  (define-arguments (*earmuffs* 'foo))
  (*earmuffs*) => 'bar)

;; Guard procedure.
(test-arguments '("--str" "bar")
  (define-arguments
    ((str) "foo"
     (lambda (str)
       (string-append str "!"))))
  (str) => "bar!")

;; Leftover arguments.
(test-arguments '("--matched" "unmatched")
  (define-arguments (matched))
  (command-line-arguments) => '("unmatched"))

;; Unmatched argument.
(test-arguments '("--matched" "-b" "--unmatched=ignored")
  (define-arguments (matched))
  (unmatched-arguments) => '((#\b . #t) ("unmatched" . "ignored")))

;; Bad default.
(test-arguments '("--foo")
  (handle-exceptions exn
    ((condition-property-accessor 'exn 'message) exn)
    (define-arguments ((foo f) (lambda (x) x)))) =/=> "invalid default value")

;; No argument given.
(test-arguments '("--foo")
  (define-arguments ((foo f) "bar")) =/=> "value required")

;; Non-numeric argument given.
(test-arguments '("--foo")
  (define-arguments ((foo f) 1)) =/=> "numeric value required")

;; Value given for boolean argument.
(test-arguments '("--foo=1")
  (define-arguments ((foo f)))
  (foo) =/=> "unexpected value")

(if (not (check-passed? 12))
  (begin (check-report)
         (error 'easy-args "Failed to pass test suite.")))