From d4d706f7f01050395da1db187801d909b344a299 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Thu, 9 Nov 2006 10:18:37 +0000 Subject: [PATCH] Moved profj-testing back to profj temporarily for the release svn: r4811 --- collects/profj/profj-testing.ss | 258 ++++++++++++++++++++++++++++++++ 1 file changed, 258 insertions(+) create mode 100644 collects/profj/profj-testing.ss diff --git a/collects/profj/profj-testing.ss b/collects/profj/profj-testing.ss new file mode 100644 index 0000000000..c32a7439af --- /dev/null +++ b/collects/profj/profj-testing.ss @@ -0,0 +1,258 @@ +(module profj-testing mzscheme + + (require (lib "compile.ss" "profj") + (lib "parameters.ss" "profj") + (lib "display-java.ss" "profj") + (lib "class.ss")) + + (define report-expected-error-messages (make-parameter #t)) + + (define interaction-errors (make-parameter 0)) + (define execution-errors (make-parameter 0)) + (define file-errors (make-parameter 0)) + (define interaction-msgs (make-parameter null)) + (define execution-msgs (make-parameter null)) + (define file-msgs (make-parameter null)) + (define missed-expected-errors (make-parameter 0)) + (define expected-failed-tests (make-parameter null)) + (define expected-error-messages (make-parameter null)) + + (provide java-values-equal?) + (define (java-values-equal? v1 v2) + (java-equal? v1 v2 null null)) + + ;java-equal?: 'a 'a (list 'a) (list 'a)-> bool + (define (java-equal? v1 v2 visited-v1 visited-v2) + (or (eq? v1 v2) + (already-seen? v1 v2 visited-v1 visited-v2) + (and (number? v1) (number? v2) (= v1 v2)) + (cond + ((and (object? v1) (object? v2)) + (cond + ((equal? "String" (send v1 my-name)) + (and (equal? "String" (send v2 my-name)) + (equal? (send v1 get-mzscheme-string) (send v2 get-mzscheme-string)))) + ((equal? "array" (send v1 my-name)) + (and (equal? "array" (send v2 my-name)) + (= (send v1 length) (send v2 length)) + (let ((v1-vals (array->list v1)) + (v2-vals (array->list v2))) + (andmap (lambda (x) x) + (map java-equal? v1-vals v2-vals + (map (lambda (v) (cons v1 visited-v1)) v1-vals) + (map (lambda (v) (cons v2 visited-v2)) v2-vals)))))) + (else + (and (equal? (send v1 my-name) (send v2 my-name)) + (let ((v1-fields (send v1 field-values)) + (v2-fields (send v2 field-values))) + (and (= (length v1-fields) (length v2-fields)) + (andmap (lambda (x) x) + (map java-equal? v1-fields v2-fields + (map (lambda (v) (cons v1 visited-v1)) v1-fields) + (map (lambda (v) (cons v2 visited-v2)) v2-fields))))))))) + ((and (not (object? v1)) (not (object? v2))) (equal? v1 v2)) + (else #f)))) + + ;array->list: java-array -> (list 'a) + (define (array->list v) + (letrec ((len (send v length)) + (build-up + (lambda (c) + (if (= c len) + null + (cons (send v access c) + (build-up (add1 c))))))) + (build-up 0))) + + ;already-seen?: 'a 'a (list 'a) (list 'a)-> bool + (define (already-seen? v1 v2 visited-v1 visited-v2) + (cond + ((and (null? visited-v1) (null? visited-v2)) #f) + ((memq v1 visited-v1) + (let ((position-v1 (get-position v1 visited-v1 0))) + (eq? v2 (list-ref visited-v2 position-v1)))) + (else #f))) + + ;get-position: 'a (list 'a) int -> int + (define (get-position v1 visited pos) + (if (eq? v1 (car visited)) + pos + (get-position v1 (cdr visited) (add1 pos)))) + + ;interact-internal: symbol (list string) (list evalable-value) string type-record -> void + (define (interact-internal level interacts vals msg type-recs) + (for-each (lambda (ent val) + (let ((st (open-input-string ent))) + (with-handlers + ([exn? + (lambda (exn) + (cond + ((and (eq? val 'error) (report-expected-error-messages)) + (expected-error-messages (cons (cons msg (exn-message exn)) (expected-error-messages)))) + ((not (eq? val 'error)) + (interaction-errors (add1 (interaction-errors))) + (interaction-msgs (cons + (format "Test ~a: Exception raised for ~a : ~a" + msg ent (exn-message exn)) (interaction-msgs))))))]) + (let ((new-val (eval `(begin + (require (lib "class.ss") + (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")) + (prefix c: (lib "contract.ss"))) + ,(compile-interactions st st type-recs level))))) + (when (eq? val 'error) + (missed-expected-errors (add1 (missed-expected-errors))) + (expected-failed-tests (cons msg (expected-failed-tests)))) + (unless (and (not (eq? val 'error)) (java-equal? (eval val) new-val null null)) + (interaction-errors (add1 (interaction-errors))) + (interaction-msgs (cons (format "Test ~a: ~a evaluated to ~a instead of ~a" + msg ent new-val val) (interaction-msgs)))))))) + interacts vals)) + + ;interact-test: symbol (list string) (list evalable-value) string | + ; : string stymbol (list string) (list evalable-value) string -> void + (define interact-test + (case-lambda + [(level in val msg) + (interact-internal level in val msg (create-type-record))] + ((defn level in val msg) + (let* ((type-recs (create-type-record)) + (def-st (open-input-string defn))) + (with-handlers + ([exn? + (lambda (exn) + (interaction-errors (add1 (interaction-errors))) + (interaction-msgs (cons (format "Test ~a: Exception raised in definition : ~a" + msg (exn-message exn)) + (interaction-msgs))))]) + (execution? #t) + (eval-modules (compile-java 'port 'port level #f def-st def-st type-recs)) + (interact-internal level in val msg type-recs)))))) + + ;interact-test-java-expected: string symbol (list string) (list string) string -> void + (define (interact-test-java-expected defn level in val msg) + (let* ((type-recs (create-type-record)) + (def-st (open-input-string defn))) + (with-handlers + ([exn? + (lambda (exn) + (interaction-errors (add1 (interaction-errors))) + (interaction-msgs (cons (format "Test ~a: Exception raised in definition : ~a" + msg (exn-message exn)) + (interaction-msgs))))]) + (execution? #t) + (eval-modules (compile-java 'port 'port level #f def-st def-st type-recs)) + (let ((vals (map (lambda (ex-val) + (let ((st (open-input-string ex-val))) + (eval `(begin (require (lib "class.ss") + (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))) + ,(compile-interactions st st type-recs level))))) + val))) + (interact-internal level in vals msg type-recs))))) + + (define (execute-test defn level error? msg) + (let ((st (open-input-string defn))) + (with-handlers + ([exn? + (lambda (exn) + (cond + ((and error? (report-expected-error-messages)) + (expected-error-messages (cons (cons msg (exn-message exn)) (expected-error-messages)))) + ((not error?) + (execution-errors (add1 (execution-errors))) + (execution-msgs (cons + (format "Test ~a : Exception-raised: ~a" msg (exn-message exn)) (execution-msgs))))))]) + (eval-modules (compile-java 'port 'port level #f st st)) + (when error? + (missed-expected-errors (add1 (missed-expected-errors))) + (expected-failed-tests (cons msg (expected-failed-tests)))) + ))) + + ;run-test: symbol string (U string (list string)) (U string (list string)) -> (U (list (list symbol bool string)) (list ...)) + (define (run-test level defn interact val) + (let* ((type-recs (create-type-record)) + (def-st (open-input-string defn)) + (check-vals + (lambda (interact val) + (with-handlers + ([exn? + (lambda (exn) + (list 'interact #f (exn-message exn)))]) + (let* ((get-val (lambda (v-st v-pe) + (eval `(begin (require (lib "class.ss")) + (require (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))) + ,(compile-interactions v-st v-st type-recs level))))) + (i-st (open-input-string interact)) + (v-st (open-input-string val)) + (i-pe (lambda () (open-input-string interact))) + (v-pe (lambda () (open-input-string val))) + (given-val (get-val i-st i-pe)) + (exp-val (get-val v-st v-pe))) + (list 'interact (java-equal? given-val exp-val null null) (format-java-value given-val #t 'field null #f 0))))))) + (with-handlers + ([exn? + (lambda (exn) + (list 'defn #f (exn-message exn)))]) + (execution? #t) + (eval-modules (compile-java 'port 'port level #f def-st def-st type-recs)) + (cond + ((and (pair? interact) (pair? val)) + (map check-vals interact val)) + ((and (string? interact) (string? val)) + (check-vals interact val)))))) + + (define (file-test file level error? msg) + (with-handlers + ([exn? + (lambda (exn) + (unless error? + (file-errors (add1 (file-errors))) + (file-msgs (cons + (format "Test ~a :Exception-raised: ~a" msg (exn-message exn)) (file-msgs)))))]) + (eval-modules (compile-java 'file 'port level file #f #f)))) + + (define (eval-modules modules) + (for-each eval + (apply append + (map compilation-unit-code modules)))) + + ;prepare-for-tests: String -> void + (define (prepare-for-tests lang-level) + (printf "Running tests for ~a~n" lang-level) + (interaction-errors 0) + (interaction-msgs null) + (execution-errors 0) + (execution-msgs null) + (file-errors 0) + (file-msgs null) + (missed-expected-errors 0) + (expected-failed-tests null) + (expected-error-messages null)) + + + ;report-test-results: -> void + (define (report-test-results) + (when (> (interaction-errors) 0) + (printf "~a Interaction errors occurred~n" (interaction-errors)) + (for-each (lambda (m) (printf "~a~n" m)) (interaction-msgs)) + (newline)) + (when (> (execution-errors) 0) + (printf "~a Execution errors occurred~n" (execution-errors)) + (for-each (lambda (m) (printf "~a~n" m)) (execution-msgs)) + (newline)) + (when (> (file-errors) 0) + (printf "~a file errors occurred~n" (file-errors)) + (for-each (lambda (m) (printf "~a~n" m)) (file-msgs)) + (newline)) + (when (> (missed-expected-errors) 0) + (printf "Failed to receive errors for these ~a tests:~n" (missed-expected-errors)) + (for-each (lambda (m) (printf "~a~n" m)) (expected-failed-tests)) + (newline)) + (when (report-expected-error-messages) + (printf "Received these expected error messages:~n") + (for-each (lambda (m) (printf "Error for test ~a : ~a~n" (car m) (cdr m))) (expected-error-messages))) + (printf "Tests completed~n")) + + (provide interact-test execute-test interact-test-java-expected file-test run-test + report-test-results prepare-for-tests report-expected-error-messages) + ) + \ No newline at end of file