#lang scheme

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

(provide test-class)

(define test-class
  (test-suite "class.ss"

    (test-suite "Predicates and Contracts"

      (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 "mixin/c"))

    (test-suite "Mixins"

      (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 "Messages"

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