;; SPDX-FileCopyrightText: 2024 Artyom Bologov
;; SPDX-License-Identifier: MIT

;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use,
;;; copy, modify, merge, publish, distribute, sublicense, and/or
;;; sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following
;;; conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;; OTHER DEALINGS IN THE SOFTWARE.

(import test
        (srfi 253))

(define-syntax check-arg-true
  (syntax-rules ()
    ((_ pred val)
     (begin
       (check-arg pred val)
       #t))))


(test-group "srfi-253"
  (test-group "check-arg"
    ;; Sanity checks
    (test-assert "check-arg-exact-integer?" (check-arg-true exact-integer? 3))
    (test-assert "check-arg-integer?" (check-arg-true integer? 3))
    (test-assert "check-arg-boolean?" (check-arg-true boolean? #f))
    (test-assert "check-arg-char?" (check-arg-true char? #\d))
    (test-assert "check-arg-complex?" (check-arg-true complex? 3+2i))
    (test-assert "check-arg-inexact?" (check-arg-true inexact? 3.8))
    (test-assert "check-arg-real?" (check-arg-true real? 3))
    (test-assert "check-arg-real?-inexact" (check-arg-true real? 3/2))
    (test-assert "check-arg-real?-float" (check-arg-true real? 3.8))
    (test-assert "check-arg-list?-empty" (check-arg-true list? '()))
    (test-assert "check-arg-list?" (check-arg-true list? '(1 2 3)))
    (test-assert "check-arg-null?" (check-arg-true null? '()))
    (test-assert "check-arg-number?-exact" (check-arg-true number? 3))
    (test-assert "check-arg-number?-complex" (check-arg-true number? 3+2i))
    (test-assert "check-arg-number?-float" (check-arg-true number? 3.8))
    (test-assert "check-arg-pair?" (check-arg-true pair? '(1 2 3)))
    (test-assert "check-arg-input-port?" (check-arg-true input-port? (current-input-port)))
    (test-assert "check-arg-output-port?" (check-arg-true output-port? (current-output-port)))
    (test-assert "check-arg-procedure?" (check-arg-true procedure? procedure?))
    (test-assert "check-arg-rational?-exact" (check-arg-true rational? 3))
    (test-assert "check-arg-rational?-inexact" (check-arg-true rational? 3/2))
    (test-assert "check-arg-string?-empty" (check-arg-true string? ""))
    (test-assert "check-arg-string?-hello" (check-arg-true string? "hello"))
    (test-assert "check-arg-symbol?" (check-arg-true symbol? 'hello))
    (test-assert "check-arg-vector?" (check-arg-true vector? #(1 2 3)))
    (test-assert "check-arg-predicate"
      (check-arg-true (lambda (x) (positive? (string-length x)))
                      "hello"))
    (test-assert "check-arg-positive?"
      (check-arg-true positive? 9))
    (test-assert "check-arg-string-length"
      (check-arg-true string-length "hello")) ;; If it works it works.
    (test-assert "check-arg-predicate-and"
      (check-arg-true (lambda (x)
                        (and (integer? x) (positive? x)))
                      8))
    (test-assert "check-arg-predicate-and-2"
      (check-arg-true ((lambda (x y)
                         (lambda (a) (and (x a) (y a))))
                       integer? positive?)
                      8))
    ;; Erroring checks
    (test-error "check-arg-string?-number errors" (check-arg-true string? 3))
    (test-error "check-arg-real?-complex errors" (check-arg-true real? 3+2i))
    (test-error "check-arg-symbol?-string errors" (check-arg-true symbol? "hello"))
    (test-error "check-arg-procedure?-number errors" (check-arg-true procedure? 3))
    ;; It is an error when predicate doesn't pass, but it doesn't have to
    ;; throw errors. Disable depending on implementation.
    (test-error "check-arg-predicate-returns-#f" (check-arg-true (lambda (a) (> a 3)) 0))
    ;; Syntax checks
    (test-assert "check-arg syntax" (begin (check-arg integer? 3 'testing-caller-arg) #t))

    ;; end test group
    )


  (test-group "values-checked"
    (test "returns single value after check"
          3
          (values-checked (integer?) 3))
    (test "works with arbitrary predicates"
          3
          (values-checked ((lambda (x) (= 3 x))) 3))
    (let ((value 3.0))
      (test "3.0 is real?"
            value
            (values-checked (real?) value))
      (test "3.0 is inexact?"
            value
            (values-checked (inexact?) value)))
    ;; Implementation-specific, might be 3.0
    (test "real number" 3 (values-checked (real?) 3))
    (test-assert "multiple values" (values-checked (integer? string?) 3 "hello"))
    (test-error "single value with false predicate" (values-checked (integer?) "hello"))
    (test-error "multiple values with false predicates" (values-checked (integer? string?) 3 3))
    ;; end test group
    )

  (test-group "check-case"
    (test-assert "check-case 1" (check-case "hello" (string? #t)))
    (test-assert "check-case 2" (check-case 3 (integer? #t) (string? #f)))
    (test-assert "check-case 3" (check-case 3.7 (inexact? #t)))
    (test-assert "check-case 4" (check-case (current-output-port) (output-port? #t)))
    (test-assert "check-case 5" (check-case #(1 2 3) (vector? #t)))
    (test-assert "check-case 6" (check-case 3 (string? #f) (else #t)))
    (test-error "missing branch" (check-case 3 (string? #t)))

    ;; end test group
    )


  (test-group "lambda-checked"
    (test-assert "lambda-checked 1" (lambda-checked () #t))
    (test-assert "lambda-checked 2" (lambda-checked args #t))
    (test-assert "lambda-checked 3" (lambda-checked (a) #t))
    (test-assert "lambda-checked 4" (lambda-checked (a b) #t))
    (test-assert "lambda-checked 5" (lambda-checked ((a integer?)) #t))
    (test-assert "lambda-checked 6" (lambda-checked (a (b integer?)) #t))
    (test-assert "lambda-checked 7" (lambda-checked ((a string?) (b integer?)) #t))
    (test-assert "lambda-checked 8" ((lambda-checked () #t)))
    (test-assert "lambda-checked 9" ((lambda-checked args #t) 1 2 3))
    (test-assert "lambda-checked 10" ((lambda-checked (a) #t) 3))
    (test-assert "lambda-checked 11" ((lambda-checked (a) #t) "hello"))
    (test-assert "lambda-checked 12" ((lambda-checked ((a integer?)) #t) 3))
    (test-assert "lambda-checked 13" ((lambda-checked (a (b integer?)) #t) 3 3))
    (test-assert "lambda-checked 14" ((lambda-checked (a (b integer?)) #t) "hello" 3))
    (test-error "lambda-checked bad arg" ((lambda-checked ((a integer?)) #t) "hello"))
    (test-error "lambda-checked mixed checks" ((lambda-checked (a (b integer?)) #t) "hello" "hi"))

    ;; end test group
    )


  (test-group "case-lambda-checked"
    (test-assert "case-lambda-checked 1"
      (case-lambda-checked
        (() #t)))
    (test-assert  "case-lambda-checked 2"
      (case-lambda-checked
        (args #t)))
    (test-assert  "case-lambda-checked 3"
      (case-lambda-checked
        ((a) #t)))
    (test-assert  "case-lambda-checked 4"
      (case-lambda-checked
        ((a) #t)))
    (test-assert  "case-lambda-checked 5"
      (case-lambda-checked
        (() #t) ((a) #t)))
    (test-assert  "case-lambda-checked 6"
      (case-lambda-checked
        (() #t) ((a) #t) (args #t)))
    (test-assert  "case-lambda-checked 7"
      (case-lambda-checked
        (((a integer?)) #t)))
    (test-assert  "case-lambda-checked 8"
      (case-lambda-checked
        (((a integer?) b) #t)))
    (test-assert  "case-lambda-checked 9"
      (case-lambda-checked
        ((a (b integer?)) #t)))
    (test-assert  "case-lambda-checked 10"
      (case-lambda-checked
        (() #t)
        (((a integer?)) #t)
        ((a (b string?)) #t)
        (args #t)))
    (define checked-case-lambda
      (case-lambda-checked
        (() #t)
        (((a integer?)) #t)
        ((a (b string?)) #t)))
    (test-assert "checked-case-lambda no args" (checked-case-lambda))
    (test-assert "checked-case-lambda integer" (checked-case-lambda 3))
    (test-error "missing checked-case-lambda clause" (checked-case-lambda "hello"))
    (test-assert "checked-case-lambda multiple args" (checked-case-lambda 3 "hello"))
    (test-assert "different predicate for multiple args" (checked-case-lambda "hi" "hello"))
    (test-error "checked-case-lambda too many args" (checked-case-lambda 3 3 3))

    ;; end test group
    )


  (test-group "define-checked"
    (define-checked (c) #t)
    (test-assert "define-checked #t" (c))
    (define-checked (c (a integer?)) #t)
    (test-assert "define-checked with integer" (c 3))
    (test-error "define-checked with string" (c "hello"))
    (define-checked (c b) #t)
    (test-assert "define-checked unchecked" (c "anything"))
    (test-error "define-checked exceeds arity" (c 1 2 3))
    (define-checked (c (b string?)) #t)
    (test-assert "define-checked accepts string" (c "hello"))
    (test-error "define-checked rejects integer" (c 3))
    (define-checked c string? "hello")
    (test-assert "define-checked no-parens" c)

    ;; end test group
    )


  (test-group "define-record-type-checked"
    (define-record-type-checked <test>
      (make-test a b)
      test?
      (a integer? test-a)
      (b string? test-b test-b-set!))
    (test-assert "type-checked record 1" (make-test 1 "hello"))
    (test-error "type-checked record 2" (make-test 1))
    (test-error "type-checked record 3" (make-test 1 2))
    (test-error "type-checked record 4" (make-test 1.2 "hello"))
    (define test-test (make-test 1 "hello"))
    (test-assert "type-checked record 5"
      (begin
        (test-b-set! test-test "foo")
        #t))
    (test-error "type-checked record 6" (test-b-set! test-test 1))

    ;; end test group
    ))