258 lines
12 KiB
Scheme
258 lines
12 KiB
Scheme
(module profj-testing mzscheme
|
|
|
|
(require (lib "compile.ss" "profj")
|
|
(lib "parameters.ss" "profj")
|
|
(lib "display-java.ss" "profj")
|
|
mzlib/class)
|
|
|
|
(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 mzlib/class
|
|
(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))
|
|
(prefix c: mzlib/contract))
|
|
,(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 mzlib/class
|
|
(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 mzlib/class)
|
|
(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)
|
|
)
|