;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; command-line.scm tests.
;;;
;;; See README and command-line.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 (use r7rs))
  (else))

(import (scheme base)
        (scheme case-lambda)
        (scheme load)
        (scheme write)
        (scheme process-context))

(cond-expand
  (chicken ; `chicken-install -test` runs from the "tests" directory.
   (define load
     (let ((load load))
       (lambda (s)
         (load (string-append "../" s))))))
  (else))

(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)
       (display expected)
       (newline)))))

(load "src/foldling/command-line.scm")

(define test-command-line
  (case-lambda
    ((line grammar expected)
     (test expected (parse-command-line line grammar)))
    ((parser line grammar expected)
     (test expected (parse-command-line parser 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") (--)))

(load "src/foldling/command-line/getopt.scm")

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

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

(load "src/foldling/command-line/getopt-long.scm")

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

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

(test-command-line
 (lambda args
   (or (apply getopt-long args)
       (apply getopt args)))
 '("-aone" "bar" "--foo")
 '((-a b) (--foo) (bar . baz))
 '((-a "one") (bar . "--foo") (--)))

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

(exit (length *failures*))