model/test.ss
(module test mzscheme

  (require (prefix srfi43: (lib "43.ss" "srfi"))
           "pool.ss"
           "buffer.ss"
           "view.ss"
           "action.ss"
           "action-util.ss"
           "class-hierarchy.ss"
           "require.ss")
  (require-schemeunit)
  (require-mz:class)
  (require-etc)

  (define (action-list=? one two)
    (and (list? one)
         (list? two)
         (= (length one) (length two))
         (andmap action=? one two)))

  (define (check-atom value)
    (assert-eq? (handle-value (pool-lookup (make-pool) value)) value))

  (define (check-value value)
    (assert (lambda (a b) (or (eq? a b) (eq? a #f)))
            (handle-value (pool-lookup (make-pool) value))
            value))

  (define (check-tag value)
    (let* ([pool (make-pool)]
           [tag1 (handle-tag (pool-lookup pool value))]
           [tag2 (handle-tag (pool-lookup pool value))])
      (assert-eq? tag1 tag2)))

  (define (check-tags one two)
    (let* ([pool (make-pool)]
           [tag1 (handle-tag (pool-lookup pool one))]
           [tag2 (handle-tag (pool-lookup pool two))])
      (assert (negate string=?)
              (symbol->string tag1)
              (symbol->string tag2))))

  (define (one-of-each-buffer obj)
    (let* ([buffer (make-buffer)])
      (for-each (curry buffer-add! buffer)
                (list
                 `(new ,obj ((x 10) (y 20)))
                 `(call ,obj method (arg1 arg2))
                 `(get ,obj x)
                 `(set ,obj y 100)
                 `(return (value))
                 `(inspect ,obj)))
      buffer))

  (define (one-of-each-actions pool obj)
    (let* ([method-stack-frame
            (make-stack-frame 2 (pool-lookup pool obj)
                              initial-stack-frame)])
      (list
       (make-new 0 initial-stack-frame initial-stack-frame
                 (pool-lookup pool obj)
                 (list (list 'x (pool-lookup pool 10))
                       (list 'y (pool-lookup pool 20))))
       (make-call 1 initial-stack-frame method-stack-frame
                  (pool-lookup pool obj)
                  'method
                  (list (pool-lookup pool 'arg1)
                        (pool-lookup pool 'arg2)))
       (make-get 2 method-stack-frame method-stack-frame
                 (pool-lookup pool obj)
                 'x)
       (make-set 3 method-stack-frame method-stack-frame
                 (pool-lookup pool obj)
                 'y
                 (pool-lookup pool 100))
       (make-return 4 method-stack-frame initial-stack-frame
                    (list (pool-lookup pool 'value)))
       (make-inspect 5 initial-stack-frame initial-stack-frame
                     (pool-lookup pool obj)))))

  (define class-one% (mz:class mz:object% (mz:super-new)))
  (define class-two% (mz:class mz:object% (mz:super-new)))
  (define class-one-one% (mz:class class-one% (mz:super-new)))
  (define class-one-one-one% (mz:class class-one-one% (mz:super-new)))
  (define class-two-one% (mz:class class-two% (mz:super-new)))
  (define class-two-two% (mz:class class-two% (mz:super-new)))

  (define (forest->sexp forest)
    (map tree->sexp (class-forest-trees forest)))
  (define (tree->sexp tree)
    (let* ([parent (class-tree-parent tree)]
           [children (class-tree-children tree)])
      (list* parent
             (class-tree-lookup parent tree)
             (forest->sexp children))))
  (define (class-sexp=? one two)
    (let compare ([one one]
                  [two two])
      (cond
       [(and (null? one) (null? two)) #t]
       [(and (mz:class? one) (mz:class? two)) (eq? one two)]
       [(and (pair? one) (pair? two))
        (and (compare (car one) (car two))
             (compare (cdr one) (cdr two)))]
       [else (equal? one two)])))

  (define test
    (make-test-suite "Sequence traces"
      (make-test-suite "Pool"
        (make-test-suite "Objects"
          (make-test-suite "tags"
            (make-test-case "preservation" (check-tag (mz:new mz:object%)))
            (make-test-case "uniqueness"
              (check-tags (mz:new mz:object%) (mz:new mz:object%))))
          (make-test-suite "fields"
            (make-test-case "default"
              (assert-equal?
               (object-fields
                (pool-lookup (make-pool) (mz:new mz:object%)))
               null))
            (make-test-case "get-unknown"
              (assert-true
               (unknown-handle?
                (object-get-field
                 (pool-lookup (make-pool) (mz:new mz:object%))
                 'x 0))))
            (make-test-case "object-fields"
              (let* ([pool (make-pool)]
                     [handle (pool-lookup pool (mz:new mz:object%))])
                (object-set-field handle 'x 0 (pool-lookup pool 20))
                (object-set-field handle 'y 0 (pool-lookup pool 40))
                (assert-equal? (object-fields handle) '(x y))))
            (make-test-case "get/set"
              (let* ([pool (make-pool)]
                     [handle (pool-lookup pool (mz:new mz:object%))])
                (object-set-field handle 'x 0 (pool-lookup pool 100))
                (object-set-field handle 'x 5 (pool-lookup pool 200))
                (object-set-field handle 'x 10 (pool-lookup pool 300))
                (assert-eq? (object-get-field handle 'x 7)
                            (pool-lookup pool 200))))))
        (make-test-suite "Atoms"
          (make-test-case "true" (check-atom #t))
          (make-test-case "false" (check-atom #f))
          (make-test-case "character" (check-atom #\c))
          (make-test-case "number" (check-atom 10))
          (make-test-case "symbol" (check-atom 'symbol))
          (make-test-case "string" (check-atom "string"))
          (make-test-case "null" (check-atom null))
          (make-test-case "void" (check-atom (void))))
        (make-test-suite "Generic Values"
          (make-test-case "list value" (check-value (list 1 2 3)))
          (make-test-case "list tag" (check-tag (list 1 2 3)))
          (make-test-case "unique tags"
            (check-tags (list 1 2 3) (list 1 2 3)))))
      (make-test-suite "Actions"
        (make-test-case "new"
          (let* ([pool (make-pool)]
                 [obj (mz:new mz:object%)])
            (assert action=?
                    (spec->action pool #f `(new ,obj ((x 10) (y 20))))
                    (make-new 0 initial-stack-frame initial-stack-frame
                              (pool-lookup pool obj)
                              (list (list 'x (pool-lookup pool 10))
                                    (list 'y (pool-lookup pool 20)))))))
        (make-test-case "call"
          (let* ([pool (make-pool)]
                 [obj (mz:new mz:object%)])
            (assert action=?
                    (spec->action pool #f `(call ,obj method (10 20)))
                    (make-call 0 initial-stack-frame
                               (make-stack-frame 1 (pool-lookup pool obj)
                                                 initial-stack-frame)
                               (pool-lookup pool obj)
                               'method
                               (list (pool-lookup pool 10)
                                     (pool-lookup pool 20))))))
        (make-test-case "return"
          (assert-exn exn:fail?
                      (lambda ()
                        (spec->action (make-pool) #f `(return (any))))))
        (make-test-case "call/return"
          (let* ([pool (make-pool)]
                 [obj (mz:new mz:object%)]
                 [prev-frame (make-stack-frame 1 (pool-lookup pool obj)
                                               initial-stack-frame)]
                 [prev-action (make-call 0 initial-stack-frame prev-frame
                                         (pool-lookup pool obj)
                                         'method null)])
            (assert action=?
                    (spec->action pool prev-action `(return (value)))
                    (make-return 1 prev-frame initial-stack-frame
                                 (list (pool-lookup pool 'value))))))
        (make-test-case "get"
          (let* ([pool (make-pool)]
                 [obj (mz:new mz:object%)])
            (assert action=?
                    (spec->action pool #f `(get ,obj field))
                    (make-get 0 initial-stack-frame initial-stack-frame
                              (pool-lookup pool obj) 'field))))
        (make-test-case "set"
          (let* ([pool (make-pool)]
                 [obj (mz:new mz:object%)])
            (assert action=?
                    (spec->action pool #f `(set ,obj field value))
                    (make-set 0 initial-stack-frame initial-stack-frame
                              (pool-lookup pool obj) 'field
                              (pool-lookup pool 'value)))))
        (make-test-case "inspect"
          (let* ([pool (make-pool)]
                 [obj (mz:new mz:object%)])
            (assert action=?
                    (spec->action pool #f `(inspect ,obj))
                    (make-inspect 0 initial-stack-frame initial-stack-frame
                                  (pool-lookup pool obj))))))
      (make-test-suite "Buffer"
        (make-test-case "one of each action"
          (let* ([obj (mz:new mz:object%)]
                 [buffer (one-of-each-buffer obj)]
                 [pool (buffer-pool buffer)])
            (assert
             action-list=?
             (buffer-update (buffer-subscribe buffer))
             (one-of-each-actions pool obj)))))
      (make-test-suite "View"
        (make-test-case "initial"
          (let* ([obj (mz:new mz:object%)]
                 [buffer (one-of-each-buffer obj)]
                 [view (make-view buffer (constant #t))])
            (assert = (view-count-actions view) 0)
            (assert = (view-count-objects view) 0)))
        (make-test-case "empty"
          (let* ([obj (mz:new mz:object%)]
                 [buffer (one-of-each-buffer obj)]
                 [view (make-view buffer (constant #f))])
            (view-update view)
            (assert = (view-count-actions view) 0)
            (assert = (view-count-objects view) 0)))
        (make-test-case "all"
          (let* ([obj (mz:new mz:object%)]
                 [buffer (one-of-each-buffer obj)]
                 [view (make-view buffer (constant #t))]
                 [pool (buffer-pool buffer)]
                 [actions (one-of-each-actions pool obj)])
            (view-update view)
            (assert = (view-count-actions view) 6)
            (assert = (view-count-objects view) 1)
            (assert action-list=?
                    (list
                     (view-get-action view 0)
                     (view-get-action view 1)
                     (view-get-action view 2)
                     (view-get-action view 3)
                     (view-get-action view 4)
                     (view-get-action view 5))
                    actions))))
      (make-test-suite "Class Hierarchy"
        (make-test-suite "Trees"
          (make-test-case "singleton tree"
            (assert class-sexp=?
                    (tree->sexp (make-class-tree class-one%))
                    `(,class-one% #f)))
          (make-test-case "insert tree parent"
            (assert class-sexp=?
                    (tree->sexp
                     (class-tree-insert class-one%
                                        (make-class-tree class-one%)))
                    `(,class-one% #f)))
          (make-test-case "insert tree child"
            (assert class-sexp=?
                    (tree->sexp
                     (class-tree-insert class-one-one%
                                        (make-class-tree class-one%)))
                    `(,class-one% #f (,class-one-one% #f))))
          )
        (make-test-suite "Forests"
          (make-test-case "empty forest"
            (assert class-sexp=?
                    (forest->sexp (make-class-forest))
                    `()))
          (make-test-case "insert forest singleton"
            (assert class-sexp=?
                    (forest->sexp
                     (class-forest-insert class-one-one% (make-class-forest)))
                    `((,class-one-one% #f))))
          (make-test-case "insert forest sibling"
            (assert class-sexp=?
                    (forest->sexp
                     (class-forest-insert
                      class-two%
                      (class-forest-insert class-one-one% (make-class-forest))))
                    `((,class-one-one% #f) (,class-two% #f))))
          (make-test-case "insert forest child"
            (assert class-sexp=?
                    (forest->sexp
                     (class-forest-insert
                      class-one-one-one%
                      (class-forest-insert class-one-one% (make-class-forest))))
                    `((,class-one-one% #f (,class-one-one-one% #f)))))
          (make-test-case "insert forest parent"
            (assert class-sexp=?
                    (forest->sexp
                     (class-forest-insert
                      class-one%
                      (class-forest-insert class-one-one% (make-class-forest))))
                    `((,class-one% #f (,class-one-one% #f)))))
          )
        )
      ))

  (define (test/gui)
    (test/graphical-ui test))

  (test/gui)

  )