;;;; check-errors-test.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(import test)
(import (only (chicken format) format) (test-utils gloss))

(test-begin "Check Errors")

;;;

(import check-errors)

(import (only (chicken blob) string->blob))
(import (only (chicken condition) condition-property-accessor))
(import srfi-4)

;;

(define-syntax test-check
  (syntax-rules ()
    ((test-check ?check ?expt ?arg0 ...)
      (test (symbol->string '?check)
            ?expt (?check 'test ?expt ?arg0 ...)) ) ) )

(define-syntax capture-error
  (syntax-rules ()
    ((capture-error ?body ...)
      (handle-exceptions exp
        (map (lambda (p) ((condition-property-accessor 'exn p) exp))
             '(location message arguments))
        ?body ... ) ) ) )

;; Basic

(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)
)

(define-syntax unbound-value
	(syntax-rules ()
		((unbound-value)
			(##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )

(test-group "for failure"
  (test-error (check-defined-value (void)))                 ;too few arguments
  (test-error (check-bound-value (unbound-value)))          ;too few arguments
  (test-error (check-defined-value 'test (void)))           ;cannot check type
  (test-error (check-bound-value 'test (unbound-value)))    ;cannot check type
  (test-error (check-fixnum 'test 1.0))
  (test-error (check-positive-fixnum 'test 0))
  (test-error (check-negative-fixnum 'test 0))
  (test-error (check-natural-fixnum 'test -1))
  (test-error (check-non-positive-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))
  (test-error (check-range 'test 0 -1))
  (test-error (check-u16vector 'test 23))
)

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

(test-group "error message"
  (test '(test "bad argument type - not a fixnum" (#f))
        (capture-error (check-fixnum 'test #f)))
  (test '(test "bad `num' argument type - not a fixnum" (#f))
        (capture-error (check-fixnum 'test #f 'num)))
  (test '(test "bad argument must be in (1.1 1.2)" (1.1))
        (capture-error (check-open-interval 'test 1.1 1.1 1.2)))
  (test '(test "bad argument must be in [1.1 1.2]" (1.0))
        (capture-error (check-closed-interval 'test 1.0 1.1 1.2)))
  (test '(test "bad argument must be in (1.1 1.2]" (1.1))
        (capture-error (check-half-open-interval 'test 1.1 1.1 1.2)))
  (test '(test "bad argument must be in [1.1 1.2)" (1.2))
        (capture-error (check-half-closed-interval 'test 1.2 1.1 1.2)))
  (test '(test "bad argument" (0 -1))
        (capture-error (check-range 'test 0 -1)))
  (test '(test "bad argument count - received 3 but expected 2" ())
        (capture-error (check-argument-count 'test 3 2)))
  (test '(test "too few arguments - received 1 but expected 2" ())
        (capture-error (check-minimum-argument-count 'test 1 2)))
)

(test-group "define-check-structure"
  (define-record-type <foo-t> (make-foo-t x) foo-t? (x foo-t-x))
  (define-check-structure <foo-t>)
  (test-assert check-<foo-t>)
  (test-error (check-<foo-t> 'test #f))
  (test-assert (check-<foo-t> 'test (##sys#make-structure <foo-t>)))
)

;;;

(test-end "Check Errors")

(test-exit)