146 lines
5.6 KiB
Scheme
146 lines
5.6 KiB
Scheme
;; load this file as a tool to run the test suites
|
|
|
|
(module run-tests mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework"))
|
|
|
|
(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 (load (build-path (collection-path "tests" "drscheme")
|
|
"README"))))
|
|
|
|
(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)))
|
|
|
|
(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))
|
|
|
|
(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)))))
|