diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index 85006dff..0dac8367 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -51,7 +51,7 @@ this))] [on-focus (lambda (on?) - (super-on-focus) + (super-on-focus on?) (when on? (send (group:get-the-frame-group) set-active-frame this)))]) (public @@ -409,7 +409,7 @@ (lambda (x) (when x (send find-edit set-searching-frame (get-top-level-window))) - (on-focus x))]) + (super-on-focus x))]) (sequence (super-init parent #f '(h-scroll)) (set-line-count 2)))) @@ -1005,8 +1005,8 @@ (super-can-close?))))]) (sequence (apply super-init args)))) - (define empty% (basic-mixin frame%)) - (define standard-menus% (standard-menus-mixin empty%)) + (define basic% (basic-mixin frame%)) + (define standard-menus% (standard-menus-mixin basic%)) (define editor% (editor-mixin standard-menus%)) (define -text% (text-mixin editor%)) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 5eb90cbe..1772488a 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -16,9 +16,9 @@ [core:file : mzlib:file^] [core:thread : mzlib:thread^] [framework:keys : framework:keys^] - [framework:test : framework:test^]) - (link [M : mred-interfaces^ (mred-interfaces@)] - [F : frameworkc^ ((require-relative-library "frameworkc.ss") + [framework:test : framework:test^] + [M : mred-interfaces^]) + (link [F : frameworkc^ ((require-relative-library "frameworkc.ss") core:string core:function core:pretty-print @@ -35,4 +35,5 @@ mzlib:file^ mzlib:thread^ (keys : framework:keys^) - (test : framework:test^)) + (test : framework:test^) + mred-interfaces^) diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index 8d624376..6d716d65 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -164,7 +164,7 @@ file<%> file-mixin - empty% + basic% standard-menus% editor% text% diff --git a/collects/framework/test.ss b/collects/framework/test.ss index e76f8955..ed8c543d 100644 --- a/collects/framework/test.ss +++ b/collects/framework/test.ss @@ -8,4 +8,5 @@ [test : framework:test^ ((require-relative-library "testr.ss") mred keys)]) (export (unit test) - (unit keys)))) + (unit keys) + (open mred)))) diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 2b290a01..24562233 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -47,13 +47,17 @@ tests. - basic connections between classes | These tests will create objects in various configurations and - | trigger situations to test their functionality. Fake user input - | expected. + | trigger situations to test their functionality. - edits to canvases: |# edit-canvas.ss #| - canvases to frames: |# canvas-frame.ss #| - edits to frames: |# edit-frame.ss #| +- garbage collection: |# gc.ss #| + + | These tests will create objects in various configurations and + | make sure that they are garbage collected + - keybindings: |# keys.ss #| | This tests all of the misc (non-scheme) keybindings diff --git a/collects/tests/framework/exit.ss b/collects/tests/framework/exit.ss index 558a8e33..a4150492 100644 --- a/collects/tests/framework/exit.ss +++ b/collects/tests/framework/exit.ss @@ -1,6 +1,6 @@ '(test 'exit:exit - (lambda (x) (not (and (eq? x 'passed) - (not (mred-running?))))) + (lambda (x) (and (eq? x 'passed) + (not (mred-running?)))) (lambda () (with-handlers ([eof-result? (lambda (x) 'passed)]) (send-sexp-to-mred '(preferences:set 'framework:verify-exit #f)) @@ -8,10 +8,12 @@ 'failed))) (test 'exit:exit - (lambda (x) (not (and (eq? x 'passed) - (not (mred-running?))))) + (lambda (x) (and (eq? x 'passed) + (not (mred-running?)))) (lambda () (with-handlers ([eof-result? (lambda (x) 'passed)]) (send-sexp-to-mred '(preferences:set 'framework:verify-exit #t)) - (send-sexp-to-mred '(queue-callback (lambda () (exit:exit)))) + (send-sexp-to-mred '(test:run-one (lambda () (exit:exit)))) + (wait-for-frame "Warning") + (send-sexp-to-mred '(test:button-push "Quit")) 'failed))) diff --git a/collects/tests/framework/frame.ss b/collects/tests/framework/frame.ss index e69de29b..08d31eb0 100644 --- a/collects/tests/framework/frame.ss +++ b/collects/tests/framework/frame.ss @@ -0,0 +1,21 @@ +(test + 'basic-mixin-creation + (lambda (x) x) + (lambda () + (send-sexp-to-mred + '(send (make-object (frame:basic-mixin frame%) "test") show #t)) + (wait-for-frame "test") + (send-sexp-to-mred + '(send (get-top-level-focus-window) show #f)) + #t)) + +(test + 'basic-mixin-creation + (lambda (x) x) + (lambda () + (send-sexp-to-mred + '(send (make-object (frame:basic-mixin frame%) "test") show #t)) + (wait-for-frame "test") + (send-sexp-to-mred + '(send (get-top-level-focus-window) show #f)) + #t)) diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss index b49269ed..36722492 100644 --- a/collects/tests/framework/framework-test-engine.ss +++ b/collects/tests/framework/framework-test-engine.ss @@ -1,25 +1,55 @@ -(thread - (let ([print-convert - (parameterize ([current-namespace (make-namespace)]) - (require-library "pconvert.ss") - (global-defined-value 'print-convert))]) - (lambda () - (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))] - [(continue) (make-semaphore 0)]) - (let loop () - (let ([sexp (read in)]) - (if (eof-object? sexp) - (begin - (close-input-port in) - (close-output-port out) - (exit)) - (begin - (write - (with-handlers ([(lambda (x) #t) - (lambda (exn) - (list 'error (if (exn? exn) - (exn-message exn) - (format "~s" exn))))]) - (list 'normal (print-convert (eval sexp)))) - out) - (loop))))))))) +(let* ([errs null] + [sema (make-semaphore 1)] + [protect + (lambda (f) + (semaphore-wait sema) + (begin0 (f) + (semaphore-post sema)))]) + (thread + (let ([print-convert + (parameterize ([current-namespace (make-namespace)]) + (require-library "pconvert.ss") + (global-defined-value 'print-convert))]) + (lambda () + (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))] + [(continue) (make-semaphore 0)]) + (let loop () + (let ([sexp (read in)]) + (if (eof-object? sexp) + (begin + (close-input-port in) + (close-output-port out) + (exit)) + (begin + (write + (let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))]) + (if (null? these-errs) + (with-handlers ([(lambda (x) #t) + (lambda (exn) + (list 'error (if (exn? exn) + (exn-message exn) + (format "~s" exn))))]) + (list 'normal (print-convert (eval sexp)))) + (list 'error + (apply string-append + (map (lambda (x) + (string-append + (if (exn? x) (exn-message x) (format "~s" x)) + (string #\newline))) + these-errs))))) + + out) + (loop))))))))) + + (let ([od (event-dispatch-handler)] + [port (current-output-port)]) + (event-dispatch-handler + (lambda (evt) + (parameterize ([current-exception-handler + (let ([oe (current-exception-handler)]) + (lambda (exn) + (protect + (lambda () + (set! errs (cons exn errs)))) + (oe exn)))]) + (od evt)))))) diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss index b566fb5d..42da65ae 100644 --- a/collects/tests/framework/load.ss +++ b/collects/tests/framework/load.ss @@ -1,66 +1,107 @@ -(test - 'testr.ss - (lambda (x) #f) - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "tests.ss" "framework") - (invoke-open-unit/sig - (compound-unit/sig - (import) - (link [mred : mred-interfaces^ (mred-interfaces@)] - [keys : framework:keys^ ((require-library "keys.ss" "framework"))] - [test : framework:test^ ((require-library "testr.ss" "framework") mred keys)]) - (export (unit test)))) - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (void))) - -(test - 'test.ss - (lambda (x) #f) - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "test.ss" "framework") - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (void))) - -(test - 'mred-interfaces.ss - (lambda (x) - (printf "Called predicate: ~a~n" x) - #f) - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "mred-interfaces.ss" "framework") - (global-defined-value 'mred-interfaces^) - (global-defined-value 'mred-interfaces@) - (void))) - -(test - 'frameworkr.ss - (lambda (x) #f) - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "frameworks.ss" "framework") - (invoke-open-unit/sig - (compound-unit/sig - (import) - (link [mred : mred-interfaces^ (mred-interfaces@)] - [core : mzlib:core^ ((require-library "corer.ss"))] - [framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)]) - (export (open framework)))) - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (global-defined-value 'frame:basic-mixin) - (global-defined-value 'editor:basic-mixin) - (global-defined-value 'exit:exit) - (void))) - -(test - 'framework.ss - (lambda (x) #f) - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "framework.ss" "framework") - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (global-defined-value 'frame:basic-mixin) - (global-defined-value 'editor:basic-mixin) - (global-defined-value 'exit:exit) - (void))) +(let ([pred (lambda (x) (void? x))]) + (test + 'macro.ss + pred + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "macro.ss" "framework") + (global-defined-value 'mixin) + (void))) + (test + 'tests.ss + (lambda (x) x) + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "tests.ss" "framework") + (unit/sig? (require-library "keys.ss" "framework")))) + (test + 'testr.ss + pred + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "tests.ss" "framework") + (invoke-open-unit/sig + (compound-unit/sig + (import) + (link [mred : mred-interfaces^ (mred-interfaces@)] + [keys : framework:keys^ ((require-library "keys.ss" "framework"))] + [test : framework:test^ ((require-library "testr.ss" "framework") mred keys)]) + (export (unit test)))) + (global-defined-value 'test:run-one) + (global-defined-value 'test:button-push) + (void))) + (test + 'test.ss + pred + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "test.ss" "framework") + (global-defined-value 'test:run-one) + (global-defined-value 'test:button-push) + (void))) + (test + 'mred-interfaces.ss + pred + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "mred-interfaces.ss" "framework") + (global-defined-value 'mred-interfaces^) + (global-defined-value 'mred-interfaces@) + (void))) + (test + 'mred-interfaces.ss/gen + (lambda (x) x) + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "mred-interfaces.ss" "framework") + (let ([orig-button% (global-defined-value 'button%)]) + (invoke-open-unit/sig mred-interfaces@) + (let ([first-button% (global-defined-value 'button%)]) + (invoke-open-unit/sig mred-interfaces@) + (let ([second-button% (global-defined-value 'button%)]) + (and (eq? second-button% first-button%) + (not (eq? first-button% orig-button%)))))))) + (test + 'frameworkr.ss + pred + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "frameworks.ss" "framework") + (invoke-open-unit/sig + (compound-unit/sig + (import) + (link [mred : mred-interfaces^ (mred-interfaces@)] + [core : mzlib:core^ ((require-library "corer.ss"))] + [framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)]) + (export (open framework)))) + (global-defined-value 'test:run-one) + (global-defined-value 'test:button-push) + (global-defined-value 'frame:basic-mixin) + (global-defined-value 'editor:basic-mixin) + (global-defined-value 'exit:exit) + (void))) + (test + 'framework.ss + pred + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "framework.ss" "framework") + (global-defined-value 'test:run-one) + (global-defined-value 'test:button-push) + (global-defined-value 'frame:basic-mixin) + (global-defined-value 'editor:basic-mixin) + (global-defined-value 'exit:exit) + (void))) + (test + 'framework.ss/gen + (lambda (x) x) + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "pretty.ss") + (let* ([op (pretty-print-print-line)] + [np (lambda x (apply op x))]) + ((global-defined-value 'pretty-print-print-line) np) + (require-library "framework.ss" "framework") + (eq? np ((global-defined-value 'pretty-print-print-line)))))) + (test + 'framework.ss/test.ss + (lambda (x) x) + '(parameterize ([current-namespace (make-namespace 'mred)]) + (let ([orig-button% (global-defined-value 'button%)]) + (require-library "test.ss" "framework") + (let* ([test-button% (global-defined-value 'button%)]) + (require-library "framework.ss" "framework") + (let* ([fw-button% (global-defined-value 'button%)]) + (and (eq? fw-button% test-button%) + (not (eq? fw-button% orig-button%))))))))) diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index e39cc8f8..8f6d03e1 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -34,12 +34,17 @@ (let-values ([(base _1 _2) (split-path program)]) ((case (system-type) [(macos) system*] - [else (lambda (x) (begin (process* x) (void)))]) + [else (lambda (x) (thread (lambda () (system* x))))]) (mred-program-launcher-path "Framework Test Engine"))) (let-values ([(in out) (tcp-accept listener)]) (set! in-port in) (set! out-port out)) - (send-sexp-to-mred '(require-library "framework.ss" "framework")))]) + (send-sexp-to-mred + '(let ([s (make-semaphore 0)]) + (queue-callback (lambda () + (require-library "framework.ss" "framework") + (semaphore-post s))) + (semaphore-wait s))))]) (values (lambda () (shutdown-mred) @@ -61,7 +66,7 @@ (or (not (char-ready? in-port)) (not (eof-object? (peek-char in-port))))) (restart-mred)) - (printf "sending to mred:~n") + (printf "~a: sending to mred:~n" section-name) (parameterize ([pretty-print-print-line (let ([prompt " "] [old-liner (pretty-print-print-line)]) @@ -101,21 +106,27 @@ [(normal) (second answer)])))))))) (define section-jump void) +(define section-name "<>") (define test (case-lambda - [(test-name failed? sexp/proc) (test test-name failed? sexp/proc 'section)] - [(test-name failed? sexp/proc jump) + [(test-name passed? sexp/proc) (test test-name passed? sexp/proc 'section)] + [(test-name passed? sexp/proc jump) (let ([failed (with-handlers ([(lambda (x) #t) (lambda (x) (if (exn? x) (exn-message x) x))]) - (failed? - (if (procedure? sexp/proc) - (sexp/proc) - (eval (send-sexp-to-mred sexp/proc)))))]) + (let ([result + (if (procedure? sexp/proc) + (sexp/proc) + (eval (send-sexp-to-mred sexp/proc)))]) + + ;; this is here to help catch any errors in generated events + (send-sexp-to-mred 'check-for-errors) + + (not (passed? result))))]) (when failed (printf "FAILED ~a: ~a~n" test-name failed) (case jump @@ -139,18 +150,21 @@ (printf "saved preferences file~n") (copy-file preferences-file old-preferences-file)) +(load-relative "utils.ss") + (let ([all-files (map symbol->string (load-relative "README"))]) (for-each (lambda (x) (when (member x all-files) (let ([oh (error-escape-handler)]) (let/ec k - (error-escape-handler (lambda () - (error-escape-handler oh) - (k (void)))) - (set! section-jump k) - (printf "beginning ~a test suite~n" x) - (load-relative x) - (error-escape-handler oh))))) + (fluid-let ([section-name x] + [section-jump k]) + (error-escape-handler (lambda () + (error-escape-handler oh) + (k (void)))) + (printf "beginning ~a test suite~n" x) + (load-relative x) + (error-escape-handler oh)))))) (if (equal? (vector) argv) all-files (vector->list argv)))) diff --git a/collects/tests/framework/prefs.ss b/collects/tests/framework/prefs.ss index 3e15ab2b..458af960 100644 --- a/collects/tests/framework/prefs.ss +++ b/collects/tests/framework/prefs.ss @@ -1,8 +1,13 @@ -(local [(define pref-file (build-path (find-system-path 'pref-dir) ".mred.prefs")) +(local [(define pref-file (build-path (find-system-path 'pref-dir) + (case (system-type) + [(macos) "MrEd Preferences"] + [(windows) "mred.pre"] + [(unix) ".mred.prefs"] + [else (error 'prefs.ss "unknown os: ~a~n" (system-type))]))) (define old-prefs (if (file-exists? pref-file) (call-with-input-file pref-file read) null)) - (define (check-eq? m s) (lambda (t) (if (eq? s t) #f m))) + (define (check-eq? s) (lambda (t) (eq? s t))) (define pref-sym 'framework:test-suite)] (call-with-output-file pref-file @@ -11,23 +16,27 @@ port)) 'truncate) (shutdown-mred) + (test 'preference-unbound - (check-eq? "couldn't remove preference binding" 'passed) + (check-eq? 'passed) `(with-handlers ([exn:unknown-preference? (lambda (x) 'passed)]) (preferences:get ',pref-sym))) (test 'preference-set-default/get - (check-eq? "set-default followed by get didn't work" 'passed) + (check-eq? 'passed) `(begin (preferences:set-default ',pref-sym 'passed symbol?) (preferences:get ',pref-sym))) (test 'preference-set/get - (check-eq? "set followed by get didn't work" 'new-pref) + (check-eq? 'new-pref) `(begin (preferences:set ',pref-sym 'new-pref) (preferences:get ',pref-sym))) - (send-sexp-to-mred '(exit:exit)) - (shutdown-mred) + (with-handlers ([eof-result? (lambda (x) (void))]) + (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f) (exit:exit)))) + (test 'preference-get-after-restart - (check-eq? "get after restart didn't work" 'new-pref) - `(preferences:get ',pref-sym))) + (check-eq? 'new-pref) + `(begin (preferences:set-default ',pref-sym 'passed symbol?) + (preferences:get ',pref-sym)))) +