;;;; check-errors Test

(use test)

;;; Basic

(use type-checks)

(test-group "check for failure"
  (test-error (check-fixnum 'test 1.0))
  (test-error (check-positive-fixnum 'test 0))
  (test-error (check-natural-fixnum 'test -1))
  (test-error (check-flonum 'test 1))
  (test-error (check-integer 'test 0.1))
  (test-error (check-positive-integer 'test 0.0))
  (test-error (check-natural-integer 'test -1.0))
  (test-error (check-number 'test 'x))
  (test-error (check-positive-number 'test -0.1))
  (test-error (check-natural-number 'test -0.1))
  (test-error (check-procedure 'test 'x))
  (test-error (check-input-port 'test 'x))
  (test-error (check-output-port 'test 'x))
  (test-error (check-list 'test 'x))
  (test-error (check-pair 'test 'x))
  (test-error (check-blob 'test 'x))
  (test-error (check-vector 'test 'x))
  (test-error (check-structure 'test 'x))
  (test-error (check-symbol 'test 1))
  (test-error (check-keyword 'test 'x))
  (test-error (check-string 'test 'x))
  (test-error (check-char 'test 'x))
  (test-error (check-boolean 'test 'x))
  (test-error (check-alist 'test 'x))
  (test-error (check-alist 'test '(23)))
  (test-error (check-alist 'test '((a . 1) ())))
  (test-error (check-minimum-argument-count 'test 0 1))
  (test-error (check-argument-count 'test 1 0))
  (test-error (check-open-interval 'test 1.1 1.1 1.2))
  (test-error (check-open-interval 'test 1.2 1.1 1.2))
  (test-error (check-closed-interval 'test 1.0 1.1 1.2))
  (test-error (check-closed-interval 'test 1.3 1.1 1.2))
  (test-error (check-half-open-interval 'test 1.1 1.1 1.2))
  (test-error (check-half-open-interval 'test 1.3 1.1 1.2))
  (test-error (check-half-closed-interval 'test 1.2 1.1 1.2))
  (test-error (check-half-closed-interval 'test 1.3 1.1 1.2))
)

;should produce no output
(check-fixnum 'test 1)
(check-positive-fixnum 'test 1)
(check-natural-fixnum 'test 0)
(check-flonum 'test 1.0)
(check-integer 'test 1.0)
(check-integer 'test 1)
(check-positive-integer 'test 1.0)
(check-positive-integer 'test 1)
(check-natural-integer 'test 0.0)
(check-natural-integer 'test 0)
(check-number 'test 1.0)
(check-number 'test 1)
(check-positive-number 'test 1.0)
(check-positive-number 'test 1)
(check-natural-number 'test 0.0)
(check-natural-number 'test 0)
(check-procedure 'test check-procedure)
(check-input-port 'test (current-input-port))
(check-output-port 'test (current-output-port))
(check-list 'test '(x))
(check-pair 'test '(x . y))
(check-blob 'test (string->blob "x"))
(check-vector 'test '#(x))
(check-structure 'test (##sys#make-structure 'x) 'x)
(check-symbol 'test 'x)
(check-keyword 'test #:x)
(check-string 'test "x")
(check-char 'test #\x)
(check-boolean 'test #t)
(check-alist 'test '())
(check-alist 'test '((a . 1)))
(check-alist 'test '((a . 1) (b . 2)))
(check-minimum-argument-count 'test 1 1)
(check-argument-count 'test 1 1)
(check-open-interval 'test 1.11 1.1 1.2)
(check-closed-interval 'test 1.1 1.1 1.2)
(check-half-open-interval 'test 1.11 1.1 1.2)
(check-half-closed-interval 'test 1.11 1.1 1.2)

(define-syntax capture-error
	(syntax-rules ()
		((capture-error ?expr)
			(handle-exceptions exp
				(let ((loc ((condition-property-accessor 'exn 'location) exp))
							(msg ((condition-property-accessor 'exn 'message) exp))
							(args ((condition-property-accessor 'exn 'arguments) exp)) )
						(list loc msg args) )
				?expr ) ) ) )

(test "Literal Message 1"
	'(test "bad argument type - not a fixnum" (#f))
	(capture-error (check-fixnum 'test #f)) )
(test "Literal Message 2"
	'(test "bad `num' argument type - not a fixnum" (#f))
	(capture-error (check-fixnum 'test #f 'num)) )

(test-group "define-check+error-type"
  (define (foo? obj) #t)
  (define-check+error-type foo)
  (test-assert error-foo)
  (test-assert check-foo)
  (define-check+error-type foo1 foo?)
  (test-assert error-foo1)
  (test-assert check-foo1)
  (define-check+error-type foo2 foo? "foodie")
  (test-assert error-foo2)
  (test-assert check-foo2)
)

;;; SRFI 4

(use srfi-4)
(use srfi-4-checks)

(test-group "srfi-4-checks"
  (test-error (check-u16vector 'test 23))

  ;no output is good
  (let ((tv (make-s8vector 2)))
    (check-s8vector 'test tv) )
)

(test-exit)