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

(import test)

(test-begin "Check Errors")

(import check-errors)

;;;

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

;; Basic

(test-group "check for failure"
  (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))
)

;should produce no output
(check-fixnum 'test 1)
(check-positive-fixnum 'test 1)
(check-negative-fixnum 'test -1)
(check-natural-fixnum 'test 0)
(check-non-positive-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)
(check-range 'test 0 1)

(define-syntax capture-error
	(syntax-rules ()
		((_ ?body ...)
      (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) )
				?body ... ) ) ) )

(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

(import srfi-4)

(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-end "Check Errors")

(test-exit)