93 lines
3.6 KiB
Scheme
93 lines
3.6 KiB
Scheme
#lang scheme/gui
|
|
(require "drscheme-test-util.ss" mzlib/etc framework scheme/string)
|
|
|
|
(provide test t rx run-test in-here write-test-modules)
|
|
|
|
;; utilities to use with scribble/reader
|
|
(define t string-append)
|
|
(define (rx . strs)
|
|
(regexp (regexp-replace* #rx" *\n *" (string-append* strs) ".*")))
|
|
|
|
(define-struct test (definitions ; string
|
|
interactions ; (union #f string)
|
|
result ; string
|
|
all?) ; boolean (#t => compare the whole window)
|
|
#:omit-define-syntaxes)
|
|
|
|
(define in-here
|
|
(let ([here (this-expression-source-directory)])
|
|
(lambda (file) (path->string (build-path here file)))))
|
|
|
|
(define tests '())
|
|
(define (test defs ints res [all? #f])
|
|
(set! tests (cons (make-test (if (string? defs) defs (format "~s" defs))
|
|
ints res all?)
|
|
tests)))
|
|
|
|
(define temp-files '())
|
|
(define (write-test-modules* name code)
|
|
(let ([file (in-here (format "~a.ss" name))])
|
|
(set! temp-files (cons file temp-files))
|
|
(with-output-to-file file #:exists 'truncate
|
|
(lambda () (printf "~s\n" code)))))
|
|
(define-syntax write-test-modules
|
|
(syntax-rules (module)
|
|
[(_ (module name lang x ...) ...)
|
|
(begin (write-test-modules* 'name '(module name lang x ...)) ...)]))
|
|
|
|
(define drs (wait-for-drscheme-frame))
|
|
(define interactions-text (send drs get-interactions-text))
|
|
|
|
(define (single-test test)
|
|
(let/ec k
|
|
(clear-definitions drs)
|
|
(insert-in-definitions drs (test-definitions test))
|
|
(do-execute drs)
|
|
|
|
(let ([ints (test-interactions test)])
|
|
|
|
(when ints
|
|
(let ([after-execute-output
|
|
(send interactions-text
|
|
get-text
|
|
(send interactions-text paragraph-start-position 2)
|
|
(send interactions-text paragraph-end-position 2))])
|
|
(unless (or (test-all? test) (string=? "> " after-execute-output))
|
|
(printf "FAILED: ~a\n ~a\n expected no output after execution, got: ~s\n"
|
|
(test-definitions test)
|
|
(or (test-interactions test) 'no-interactions)
|
|
after-execute-output)
|
|
(k (void)))
|
|
(type-in-interactions drs ints)
|
|
(test:keystroke #\return)
|
|
(wait-for-computation drs)))
|
|
|
|
(let* ([text
|
|
(if (test-all? test)
|
|
(send interactions-text get-text)
|
|
(let* ([para (- (send interactions-text position-paragraph
|
|
(send interactions-text last-position))
|
|
1)])
|
|
(send interactions-text
|
|
get-text
|
|
(send interactions-text paragraph-start-position para)
|
|
(send interactions-text paragraph-end-position para))))]
|
|
[passed? (let ([r (test-result test)])
|
|
((cond [(string? r) string=?]
|
|
[(regexp? r) regexp-match?]
|
|
[else 'module-lang-test "bad test value: ~e" r])
|
|
r text))])
|
|
(unless passed?
|
|
(printf "FAILED: ~a\n ~a\n expected: ~s\n got: ~s\n"
|
|
(test-definitions test)
|
|
(or (test-interactions test) 'no-interactions)
|
|
(test-result test)
|
|
text))))))
|
|
|
|
(define (run-test)
|
|
(set-language-level! '("Module") #t)
|
|
(for-each single-test (reverse tests))
|
|
(clear-definitions drs)
|
|
(send (send drs get-definitions-text) set-modified #f)
|
|
(for ([file temp-files]) (when (file-exists? file) (delete-file file))))
|