59 lines
2.1 KiB
Scheme
59 lines
2.1 KiB
Scheme
;; load this file as a tool to run the test suites
|
|
|
|
(module tool mzscheme
|
|
(require drscheme/tool
|
|
mzlib/list
|
|
mzlib/unit
|
|
mzlib/class
|
|
mred
|
|
framework
|
|
"README.ss")
|
|
|
|
(provide tool@)
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drscheme:tool^)
|
|
(export drscheme:tool-exports^)
|
|
(define (phase1) (void))
|
|
(define (phase2) (void))
|
|
|
|
(preferences:set-default 'drscheme:test-suite:file-name "repl-tests.ss" string?)
|
|
(preferences:set-default 'drscheme:test-suite:run-interval 10 number?)
|
|
|
|
(preferences:set-default 'drscheme:test-suite:frame-width #f (lambda (x) (or (not x) (number? x))))
|
|
(preferences:set-default 'drscheme:test-suite:frame-height 300 (lambda (x) (or (not x) (number? x))))
|
|
|
|
(define (tool-mixin super%)
|
|
(class super%
|
|
(inherit get-button-panel)
|
|
(super-new)
|
|
(let* ([bitmap (make-object bitmap%
|
|
(if (<= (get-display-depth) 1)
|
|
(build-path (collection-path "icons") "bb-sm-bw.bmp")
|
|
(build-path (collection-path "icons") "bb-small.bmp"))
|
|
'bmp)]
|
|
[button (make-object button%
|
|
(if (send bitmap ok?) bitmap "Console")
|
|
(get-button-panel)
|
|
(lambda (button evt)
|
|
(let ([ask-test-suite (dynamic-require 'tests/drscheme/run-tests
|
|
'ask-test-suite)])
|
|
(ask-test-suite this))))])
|
|
(send (get-button-panel) change-children
|
|
(lambda (l)
|
|
(cons button (remq button l)))))))
|
|
|
|
(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)]))))
|
|
|