added a little more automation to the drscheme test suite
svn: r16341
This commit is contained in:
Robby Findler
parent
2043cb19ff
commit
40547e86a2
|
|
@ -1,4 +1,7 @@
|
|||
(#|
|
||||
#lang scheme/base
|
||||
(provide all-tests)
|
||||
(define all-tests (map symbol->string '(
|
||||
#|
|
||||
|
||||
This directory contains code for testing DrScheme. To run the tests,
|
||||
load run-test.ss. It will return a function that accepts the names of
|
||||
|
|
@ -50,4 +53,4 @@ the function, all tests will be run.
|
|||
|
||||
|# syncheck-test.ss #|
|
||||
|
||||
|#)
|
||||
|#)))
|
||||
|
|
|
|||
|
|
@ -1,148 +1,143 @@
|
|||
;; load this file as a tool to run the test suites
|
||||
|
||||
(module run-tests mzscheme
|
||||
(require mzlib/class
|
||||
mred
|
||||
framework)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui/base
|
||||
framework
|
||||
"README")
|
||||
|
||||
(provide ask-test-suite)
|
||||
|
||||
(define test-thread
|
||||
(let ([kill-old void])
|
||||
(lambda (test thunk)
|
||||
(kill-old)
|
||||
(let ([thread-desc (thread
|
||||
(lambda ()
|
||||
(printf "t>> ~a started~n" test)
|
||||
(thunk)
|
||||
(printf "t>> ~a finished~n" test)))])
|
||||
(set! kill-old
|
||||
(lambda ()
|
||||
(when (thread-running? thread-desc)
|
||||
(kill-thread thread-desc)
|
||||
(printf "t>> killed ~a~n" test))))))))
|
||||
|
||||
(define all-tests
|
||||
(map symbol->string
|
||||
(call-with-input-file (build-path (collection-path "tests" "drscheme")
|
||||
"README")
|
||||
read)))
|
||||
|
||||
(define (make-repl)
|
||||
(test-thread
|
||||
"REPL"
|
||||
(lambda ()
|
||||
(let ([startup "~/.mzschemerc"])
|
||||
(when (file-exists? startup)
|
||||
(load startup)))
|
||||
(case (system-type)
|
||||
[(windows macos)
|
||||
(graphical-read-eval-print-loop (current-eventspace))]
|
||||
[else
|
||||
(read-eval-print-loop)]))))
|
||||
|
||||
(define (run-test-suite filename)
|
||||
(test-thread
|
||||
filename
|
||||
(lambda ()
|
||||
((dynamic-require `(lib ,filename "tests" "drscheme") 'run-test)))))
|
||||
|
||||
(define current-test-suite-frame #f)
|
||||
|
||||
(define test-suite-frame%
|
||||
(class frame%
|
||||
(define/override (on-size w h)
|
||||
(preferences:set 'drscheme:test-suite:frame-width w)
|
||||
(preferences:set 'drscheme:test-suite:frame-height h))
|
||||
(define/augment (on-close)
|
||||
(inner (void) on-close)
|
||||
(set! current-test-suite-frame #f))
|
||||
(super-new)))
|
||||
(provide ask-test-suite run-test-suite)
|
||||
|
||||
(define (ask-test-suite parent)
|
||||
(if current-test-suite-frame
|
||||
(send current-test-suite-frame show #t)
|
||||
(let* ([drscheme-test-dir (collection-path "tests" "drscheme")]
|
||||
[frame (make-object test-suite-frame%
|
||||
"Test Suites"
|
||||
parent
|
||||
(preferences:get 'drscheme:test-suite:frame-width)
|
||||
(preferences:get 'drscheme:test-suite:frame-height))]
|
||||
[panel (make-object vertical-panel% frame)]
|
||||
[top-panel (make-object vertical-panel% panel)]
|
||||
[bottom-panel (make-object horizontal-panel% panel)])
|
||||
(send top-panel stretchable-height #f)
|
||||
(make-object button%
|
||||
"REPL"
|
||||
bottom-panel
|
||||
(lambda (_1 _2)
|
||||
(send frame show #f)
|
||||
(make-repl)))
|
||||
|
||||
(when drscheme-test-dir
|
||||
(send top-panel stretchable-height #t)
|
||||
(send bottom-panel stretchable-height #f)
|
||||
(letrec ([lb (make-object list-box%
|
||||
#f
|
||||
all-tests
|
||||
top-panel
|
||||
(lambda (b e)
|
||||
(when (eq? (send e get-event-type) 'list-box-dclick)
|
||||
(run-test-suite-callback))))]
|
||||
[run-test-suite-callback
|
||||
(lambda ()
|
||||
(let ([selection (send lb get-selection)])
|
||||
(when selection
|
||||
(send frame show #f)
|
||||
(let ([test (list-ref all-tests selection)])
|
||||
(preferences:set
|
||||
'drscheme:test-suite:file-name
|
||||
test)
|
||||
(run-test-suite
|
||||
test)))))])
|
||||
|
||||
;; set values from preferences
|
||||
(let* ([test-suite (preferences:get 'drscheme:test-suite:file-name)]
|
||||
[num (send lb find-string test-suite)])
|
||||
(when num
|
||||
(send lb set-string-selection test-suite)
|
||||
(send lb set-first-visible-item num)
|
||||
(test:run-interval (preferences:get 'drscheme:test-suite:run-interval))))
|
||||
|
||||
(send
|
||||
(make-object button%
|
||||
"Run Test Suite"
|
||||
bottom-panel
|
||||
(lambda (_1 _2)
|
||||
(run-test-suite-callback))
|
||||
'(border))
|
||||
focus))
|
||||
(define test-thread
|
||||
(let ([kill-old void])
|
||||
(lambda (test thunk)
|
||||
(kill-old)
|
||||
(let ([thread-desc (thread
|
||||
(lambda ()
|
||||
(printf "t>> ~a started~n" test)
|
||||
(thunk)
|
||||
(printf "t>> ~a finished~n" test)))])
|
||||
(set! kill-old
|
||||
(lambda ()
|
||||
(when (thread-running? thread-desc)
|
||||
(kill-thread thread-desc)
|
||||
(printf "t>> killed ~a~n" test))))))))
|
||||
|
||||
(define (make-repl)
|
||||
(test-thread
|
||||
"REPL"
|
||||
(lambda ()
|
||||
(let ([startup "~/.mzschemerc"])
|
||||
(when (file-exists? startup)
|
||||
(load startup)))
|
||||
(case (system-type)
|
||||
[(windows macos)
|
||||
(graphical-read-eval-print-loop (current-eventspace))]
|
||||
[else
|
||||
(read-eval-print-loop)]))))
|
||||
|
||||
(define (run-test-suite filename [die-afterwards? #f])
|
||||
(test-thread
|
||||
filename
|
||||
(lambda ()
|
||||
((dynamic-require `(lib ,filename "tests" "drscheme") 'run-test))
|
||||
(when die-afterwards? (exit)))))
|
||||
|
||||
(define current-test-suite-frame #f)
|
||||
|
||||
(define test-suite-frame%
|
||||
(class frame%
|
||||
(define/override (on-size w h)
|
||||
(preferences:set 'drscheme:test-suite:frame-width w)
|
||||
(preferences:set 'drscheme:test-suite:frame-height h))
|
||||
(define/augment (on-close)
|
||||
(inner (void) on-close)
|
||||
(set! current-test-suite-frame #f))
|
||||
(super-new)))
|
||||
|
||||
(define (ask-test-suite parent)
|
||||
(if current-test-suite-frame
|
||||
(send current-test-suite-frame show #t)
|
||||
(let* ([drscheme-test-dir (collection-path "tests" "drscheme")]
|
||||
[frame (make-object test-suite-frame%
|
||||
"Test Suites"
|
||||
parent
|
||||
(preferences:get 'drscheme:test-suite:frame-width)
|
||||
(preferences:get 'drscheme:test-suite:frame-height))]
|
||||
[panel (make-object vertical-panel% frame)]
|
||||
[top-panel (make-object vertical-panel% panel)]
|
||||
[bottom-panel (make-object horizontal-panel% panel)])
|
||||
(send top-panel stretchable-height #f)
|
||||
(make-object button%
|
||||
"REPL"
|
||||
bottom-panel
|
||||
(lambda (_1 _2)
|
||||
(send frame show #f)
|
||||
(make-repl)))
|
||||
|
||||
(when drscheme-test-dir
|
||||
(send top-panel stretchable-height #t)
|
||||
(send bottom-panel stretchable-height #f)
|
||||
(letrec ([lb (make-object list-box%
|
||||
#f
|
||||
all-tests
|
||||
top-panel
|
||||
(lambda (b e)
|
||||
(when (eq? (send e get-event-type) 'list-box-dclick)
|
||||
(run-test-suite-callback))))]
|
||||
[run-test-suite-callback
|
||||
(lambda ()
|
||||
(let ([selection (send lb get-selection)])
|
||||
(when selection
|
||||
(send frame show #f)
|
||||
(let ([test (list-ref all-tests selection)])
|
||||
(preferences:set
|
||||
'drscheme:test-suite:file-name
|
||||
test)
|
||||
(run-test-suite test)))))])
|
||||
|
||||
(let* ([pre-times (list 0 10 50 100 500)]
|
||||
[times (if (member (test:run-interval) pre-times)
|
||||
pre-times
|
||||
(append pre-times (list (test:run-interval))))]
|
||||
[choice
|
||||
(make-object choice%
|
||||
"Run Interval"
|
||||
(map number->string times)
|
||||
top-panel
|
||||
(lambda (choice event)
|
||||
(let ([time (list-ref times (send choice get-selection))])
|
||||
(preferences:set 'drscheme:test-suite:run-interval time)
|
||||
(test:run-interval time))))])
|
||||
(send choice set-selection
|
||||
(let loop ([l times]
|
||||
[n 0])
|
||||
(if (= (car l) (test:run-interval))
|
||||
n
|
||||
(loop (cdr l)
|
||||
(+ n 1)))))))
|
||||
(make-object button%
|
||||
"Cancel"
|
||||
bottom-panel
|
||||
(lambda (_1 _2)
|
||||
(send frame show #f)))
|
||||
(make-object grow-box-spacer-pane% bottom-panel)
|
||||
(send frame show #t)
|
||||
(set! current-test-suite-frame frame)))))
|
||||
;; set values from preferences
|
||||
(let* ([test-suite (preferences:get 'drscheme:test-suite:file-name)]
|
||||
[num (send lb find-string test-suite)])
|
||||
(when num
|
||||
(send lb set-string-selection test-suite)
|
||||
(send lb set-first-visible-item num)
|
||||
(test:run-interval (preferences:get 'drscheme:test-suite:run-interval))))
|
||||
|
||||
(send
|
||||
(make-object button%
|
||||
"Run Test Suite"
|
||||
bottom-panel
|
||||
(lambda (_1 _2)
|
||||
(run-test-suite-callback))
|
||||
'(border))
|
||||
focus))
|
||||
|
||||
(let* ([pre-times (list 0 10 50 100 500)]
|
||||
[times (if (member (test:run-interval) pre-times)
|
||||
pre-times
|
||||
(append pre-times (list (test:run-interval))))]
|
||||
[choice
|
||||
(make-object choice%
|
||||
"Run Interval"
|
||||
(map number->string times)
|
||||
top-panel
|
||||
(lambda (choice event)
|
||||
(let ([time (list-ref times (send choice get-selection))])
|
||||
(preferences:set 'drscheme:test-suite:run-interval time)
|
||||
(test:run-interval time))))])
|
||||
(send choice set-selection
|
||||
(let loop ([l times]
|
||||
[n 0])
|
||||
(if (= (car l) (test:run-interval))
|
||||
n
|
||||
(loop (cdr l)
|
||||
(+ n 1)))))))
|
||||
(make-object button%
|
||||
"Cancel"
|
||||
bottom-panel
|
||||
(lambda (_1 _2)
|
||||
(send frame show #f)))
|
||||
(make-object grow-box-spacer-pane% bottom-panel)
|
||||
(send frame show #t)
|
||||
(set! current-test-suite-frame frame))))
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
mzlib/unit
|
||||
mzlib/class
|
||||
mred
|
||||
framework)
|
||||
framework
|
||||
"README")
|
||||
|
||||
(provide tool@)
|
||||
|
||||
|
|
@ -43,6 +44,15 @@
|
|||
(lambda (l)
|
||||
(cons button (remq button l)))))))
|
||||
|
||||
(when (getenv "PLTDRTESTS")
|
||||
(printf "PLTDRTESTS: installing unit frame mixin\n")
|
||||
(drscheme:get/extend:extend-unit-frame tool-mixin)))))
|
||||
(define tests (getenv "PLTDRTESTS"))
|
||||
|
||||
(cond
|
||||
[(not tests) (void)]
|
||||
[(member tests all-tests)
|
||||
((dynamic-require 'tests/drscheme/run-tests 'run-test-suite)
|
||||
tests
|
||||
#t)]
|
||||
[else
|
||||
(printf "PLTDRTESTS: installing unit frame mixin\n")
|
||||
(drscheme:get/extend:extend-unit-frame tool-mixin)]))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user