#lang scheme

(require "checks.ss"
         "../contract.ss")

(provide test-contract)

(define test-contract
  (test-suite "contract.ss"
    (test-suite "Flat Contracts"
      (test-suite "nat/c"
        (test-ok (with/c nat/c 1))
        (test-ok (with/c nat/c 0))
        (test-bad (with/c nat/c -1))
        (test-bad (with/c nat/c 'non-numeric)))
      (test-suite "pos/c"
        (test-ok (with/c pos/c 1))
        (test-bad (with/c pos/c 0))
        (test-bad (with/c pos/c -1))
        (test-bad (with/c pos/c 'non-numeric)))
      (test-suite "truth/c"
        (test-ok (with/c truth/c #t))
        (test-ok (with/c truth/c #f))
        (test-ok (with/c truth/c '(x)))))
    (test-suite "Higher Order Contracts"
      (test-suite "thunk/c"
        (test-ok ([with/c thunk/c gensym]))
        (test-bad ([with/c thunk/c gensym] 'x))
        (test-bad ([with/c thunk/c cons])))
      (test-suite "unary/c"
        (test-ok ([with/c unary/c list] 'x))
        (test-bad ([with/c unary/c list] 'x 'y))
        (test-bad ([with/c unary/c cons] 1)))
      (test-suite "binary/c"
        (test-ok ([with/c binary/c +] 1 2))
        (test-bad ([with/c binary/c +] 1 2 3))
        (test-bad ([with/c binary/c symbol->string] 'x 'y)))
      (test-suite "predicate/c"
        (test-ok ([with/c predicate/c integer?] 1))
        (test-ok ([with/c predicate/c integer?] 1/2))
        (test-bad ([with/c predicate/c values] 'x)))
      (test-suite "predicate-like/c"
        (test-ok ([with/c predicate-like/c integer?] 1))
        (test-ok ([with/c predicate-like/c integer?] 1/2))
        (test-ok ([with/c predicate-like/c values] 'x)))
      (test-suite "comparison/c"
        (test-ok ([with/c comparison/c equal?] 1 1))
        (test-ok ([with/c comparison/c equal?] 1 2))
        (test-bad ([with/c comparison/c list] 1 2)))
      (test-suite "comparison-like/c"
        (test-ok ([with/c comparison-like/c equal?] 1 1))
        (test-ok ([with/c comparison-like/c equal?] 1 2))
        (test-ok ([with/c comparison-like/c list] 1 2))))))