49 lines
2.0 KiB
Scheme
49 lines
2.0 KiB
Scheme
;; load this file as a tool to run the test suites
|
|
|
|
(module tool mzscheme
|
|
(require (lib "tool.ss" "drscheme")
|
|
(lib "list.ss")
|
|
(lib "unit.ss")
|
|
(lib "class.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework"))
|
|
|
|
(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 '(lib "run-tests.ss" "tests" "drscheme")
|
|
'ask-test-suite)])
|
|
(ask-test-suite this))))])
|
|
(send (get-button-panel) change-children
|
|
(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)))))
|