#lang scheme

(require (planet schematics/schemeunit:2:10/test)
         "checks.ss"
         "../class.ss")

(provide test-class)

(define test-class
  (test-suite "class.ss"
    (test-suite "class-or-interface/c"
      (test-case "accept object%"
        (check-contract-accept class-or-interface/c object%))
      (test-case "accept empty interface"
        (check-contract-accept class-or-interface/c (interface ())))
      (test-case "reject instance of object%"
        (check-contract-reject class-or-interface/c (new object%))))
    (test-suite "object/c"
      (test-case "accept instance w/o arguments"
        (check-contract-accept (object/c) (new object%)))
      (test-case "accept instance of class"
        (let* ([c% (class object% (super-new))])
          (check-contract-accept (object/c c%) (new c%))))
      (test-case "accept instance of interface"
        (let* ([i<%> (interface ())]
               [c% (class* object% (i<%>) (super-new))])
          (check-contract-accept (object/c i<%>) (new c%))))
      (test-case "reject instance w/o class"
        (let* ([c% (class object% (super-new))])
          (check-contract-reject (object/c c%) (new object%))))
      (test-case "reject instance w/o interface"
        (let* ([i<%> (interface ())])
          (check-contract-reject (object/c i<%>) (new object%))))
      (test-case "reject class"
        (check-contract-reject (object/c) object%)))
    (test-suite "class/c"
      (test-case "accept object% w/o arguments"
        (check-contract-accept (class/c) object%))
      (test-case "accept class"
        (let* ([c% (class object% (super-new))])
          (check-contract-accept (class/c c%) c%)))
      (test-case "accept implementation"
        (let* ([i<%> (interface ())]
               [c% (class* object% (i<%>) (super-new))])
          (check-contract-accept (class/c i<%>) c%)))
      (test-case "reject non-subclass"
        (let* ([c% (class object% (super-new))])
          (check-contract-reject (class/c c%) object%)))
      (test-case "reject non-implementation"
        (let* ([i<%> (interface ())])
          (check-contract-reject (class/c i<%>) object%))))
    (test-suite "ensure-interface"
      (test-case "implementation unchanged"
        (let* ([i<%> (interface ())]
               [c% (class* object% (i<%>) (super-new))]
               [mx (lambda (parent%) (class* parent% (i<%>) (super-new)))])
          (check-eq? (ensure-interface i<%> mx c%) c%)))
      (test-case "non-implementation subclassed"
        (let* ([i<%> (interface ())]
               [c% (class object% (super-new))]
               [mx (lambda (parent%) (class* parent% (i<%>) (super-new)))]
               [result (ensure-interface i<%> mx c%)])
          (check-pred class? result)
          (check subclass? result c%)
          (check implementation? result i<%>))))
    (test-suite "mixin/c")
    (test-suite "send+"
      (test-case "no messages"
        (let* ([o (new object%)])
          (check-eq? (send+ o) o)))
      (test-case "multiple messages"
        (let* ([c% (class object%
                     (super-new)
                     (init-field count)
                     (define/public (add n) (set! count (+ count n)))
                     (define/public (get) count))]
               [o (new c% [count 0])])
          (check-eq? (send+ o [add 1] [add 2]) o)
          (check = (send o get) 3))))
    (test-suite "send-each"
      (test-case "counter"
        (let* ([c% (class object%
                     (super-new)
                     (init-field count)
                     (define/public (add n) (set! count (+ count n)))
                     (define/public (get) count))]
               [o1 (new c% [count 1])]
               [o2 (new c% [count 2])]
               [o3 (new c% [count 3])])
          (send-each (list o1 o2 o3) add 3)
          (check-equal? (list (send o1 get) (send o2 get) (send o3 get))
                        (list 4 5 6)))))))