(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)] [assoc (class-tree-assoc tree)] [children (class-tree-children tree)]) (list* parent assoc (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% 'assoc)) `(,class-one% assoc))) (make-test-case "insert tree parent" (assert class-sexp=? (tree->sexp (class-tree-insert class-one% (make-class-tree class-one% 'one) 'two)) `(,class-one% two))) (make-test-case "insert tree child" (assert class-sexp=? (tree->sexp (class-tree-insert class-one-one% (make-class-tree class-one% 'one) 'two)) `(,class-one% one (,class-one-one% two)))) ) (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) 'one)) `((,class-one-one% one)))) (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) 'one) 'two)) `((,class-one-one% one) (,class-two% two)))) (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) 'one) 'two)) `((,class-one-one% one (,class-one-one-one% two))))) (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) 'one) 'two)) `((,class-one% two (,class-one-one% one))))) ) ) )) (define (test/gui) (test/graphical-ui test)) (test/gui) )