;;;; check-errors Test

(use test)

;;; Basic

(use type-checks)

(test-error (check-fixnum 'test 1.0))
(test-error (check-positive-fixnum 'test 0))
(test-error (check-cardinal-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-cardinal-integer 'test -1.0))
(test-error (check-number 'test 'x))
(test-error (check-positive-number 'test -0.1))
(test-error (check-cardinal-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-cardinal-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-cardinal-integer 'test 0.0)
(check-cardinal-integer 'test 0)
(check-number 'test 1.0)
(check-number 'test 1)
(check-positive-number 'test 1.0)
(check-positive-number 'test 1)
(check-cardinal-number 'test 0.0)
(check-cardinal-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)

;;; Conditions

(use conditions)

(define testc (make-exn-condition+ 'test "test" '(test) 'test '(extra test 23)))
(define testc? (make-condition-predicate exn test extra))
(test-assert (testc? testc))
(test 23 ((condition-property-accessor 'extra 'test) testc))

(define testc-extra-test (make-condition-property-accessor extra test))
(define testc-extra-foo (make-condition-property-accessor extra foo 'foobar))
(test 23 (testc-extra-test testc))
(test 'foobar (testc-extra-foo testc))

(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-error (check-u16vector 'test 23))

(let ((tv (make-s8vector 2))) (check-s8vector 'test tv))