;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; optimism.scm tests.
;;;
;;; See README and optimism.sld for more information.
;;;
;;; This software is written by Evan Hanson <evhan@foldling.org> and
;;; placed in the Public Domain. All warranties are disclaimed.
;;;

(cond-expand
  (chicken
   (import (optimism)
           (rename (optimism getopt)
                   (parse-command-line parse-command-line/getopt))
           (rename (optimism getopt-long)
                   (parse-command-line parse-command-line/getopt-long))))
  (else
   (import (foldling optimism)
           (rename (foldling optimism getopt)
                   (parse-command-line parse-command-line/getopt))
           (rename (foldling optimism getopt-long)
                   (parse-command-line parse-command-line/getopt-long))
           (scheme base)
           (scheme case-lambda)
           (scheme process-context)
           (scheme write))))

(define *failures* '())

(define-syntax test
  (syntax-rules ()
    ((_ expected form)
     (let ((passed? (equal? expected form)))
       (unless passed? (set! *failures* (cons 'form *failures*)))
       (display (if passed? '(PASS) '(FAIL)))
       (display #\space)
       (write expected)
       (newline)))))

(define test-command-line
  (case-lambda
    ((line grammar expected)
     (test expected (parse-command-line line grammar)))
    ((parser line grammar expected)
     (test expected (parser line grammar)))
    ((parser matcher line grammar expected)
     (test expected (parser matcher line grammar)))))

(test-command-line
  '("foo" "bar")
  '((foo . bar))
  '((foo . "bar") (--)))

(test-command-line
  '("foo" "bar" "baz" "qux")
  '((foo) (bar baz qux))
  '((foo) (bar "baz" "qux") (--)))

(test-command-line
  '("foo" "bar" "baz")
  '((foo . bar))
  '((foo . "bar") (-- "baz")))

(test-command-line
 '("foo" "bar" "--" "baz" "qux")
 '((foo . bar) (baz . qux))
 '((foo . "bar") (-- "baz" "qux")))

(test-command-line
 '("foo" "one" "2" "three")
 `((foo ,list ,string->number ,string->symbol))
 '((foo ("one") 2 three) (--)))

(test-command-line
 '("foo" "bar" "baz" "qux")
 '(((foo bar baz) . qux))
 '((foo . "bar") (baz . "qux") (--)))

(test-command-line parse-command-line getopt
 '("-abcone" "-d" "two")
 '((-a) (-b) (-c . foo) (-d . bar))
 '((-a) (-b) (-c . "one") (-d . "two") (--)))

(test-command-line parse-command-line getopt
 '("-aone" "bar" "--foo")
 '((-a b) (--foo) (bar . baz))
 '((-a "one") (bar . "--foo") (--)))

(test-command-line parse-command-line getopt
 '("-abfoo" "-cfoo" "--" "-d")
 '((-a foo) (-b) (-c) (-d))
 '((-a "bfoo") (-c) (-- "-foo" "-d")))

(test-command-line parse-command-line getopt-long
 '("--foo" "--bar=one" "--baz" "two")
 '((--foo) (--bar . h) (--baz . k))
 '((--foo) (--bar . "one") (--baz . "two") (--)))

(test-command-line parse-command-line getopt-long
 '("--foo" "--bar=" "--" "--baz")
 '((--foo) (--bar x) (--baz))
 '((--foo) (--bar "") (-- "--baz")))

(test-command-line parse-command-line/getopt
 '("-ab" "-c" "d" "e" "f")
 '((-a) (-b) (-c d e f))
 '((-a) (-b) (-c "d" "e" "f") (--)))

(test-command-line parse-command-line/getopt-long
 '("--foo" "--bar=baz")
 '((--foo) (--bar . baz))
 '((--foo) (--bar . "baz") (--)))

(test-command-line parse-command-line
 (lambda (arg grammar)
   (lambda (args process)
     (process (cons (string->symbol arg) string->number)
              (cons #t (cdr args)))))
 '("one" "1" "two" "2" "three" "3")
 '() ; Ignored.
 '((one . 1) (two . 2) (three . 3) (--)))

(unless (null? *failures*)
  (display (length *failures*))
  (display " failures")
  (newline))

(exit (length *failures*))