diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 1edfc822..406b6384 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -2,12 +2,11 @@ (compile-allow-cond-fallthrough #t) (compile-allow-set!-undefined #t) (require-library "mred-interfaces.ss" "framework") -(require-library "sig.ss" "framework") -(invoke-unit/sig +(require-library "framework.ss" "framework") +(invoke-open-unit/sig (compound-unit/sig (import) (link [M : mred-interfaces^ (mred-interfaces@)] [C : mzlib:core^ ((require-library "corer.ss"))] [F : framework^ ((require-library "frameworkr.ss" "framework") C M)]) - (export))) -'done \ No newline at end of file + (export (open F)))) diff --git a/collects/framework/sig.ss b/collects/framework/frameworks.ss similarity index 100% rename from collects/framework/sig.ss rename to collects/framework/frameworks.ss diff --git a/collects/framework/main.ss b/collects/framework/main.ss index fa0a9ad0..146ea472 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -209,4 +209,5 @@ (preferences:save)))) ;(wx:application-file-handler edit-file) ;; how to handle drag and drop? - ) + + (void)) diff --git a/collects/framework/test.ss b/collects/framework/test.ss index 04e730ab..58ee5d6c 100644 --- a/collects/framework/test.ss +++ b/collects/framework/test.ss @@ -10,7 +10,7 @@ (printf "4~n") (require-library "mred-interfaces.ss" "framework") (printf "5~n") -(require-library "sig.ss" "framework") +(require-library "frameworks.ss" "framework") (printf "6~n") (define framework@ (require-library "frameworkr.ss" "framework")) (printf "7~n") diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 6811ee5a..5494cc9d 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -11,6 +11,11 @@ There will be a main mzscheme process which will start up a new mred as necessary for the test suites. Since some tests actually require mred to exit in order to pass, this governor is required. +- exit: |# exit.ss #| + + | This tests that exit:exit really exits and that the exit callbacks + | are actually run. + - preferences: |# prefs.ss #| | This tests that preferences are saved and restored correctly, both @@ -19,10 +24,12 @@ mred to exit in order to pass, this governor is required. - individual object tests: | These tests are simple object creation and basic operations. + | Each test assumes that the others pass; this may yield strange + | error messages when one fails. - - edits: |# edit.ss #| - frames: |# frame.ss #| - canvases: |# canvas.ss #| + - edits: |# edit.ss #| - basic connections between classes diff --git a/collects/tests/framework/exit.ss b/collects/tests/framework/exit.ss new file mode 100644 index 00000000..53c8f1c5 --- /dev/null +++ b/collects/tests/framework/exit.ss @@ -0,0 +1 @@ +(send-sexp-to-mred '(exit:exit)) \ No newline at end of file diff --git a/collects/tests/framework/frame.ss b/collects/tests/framework/frame.ss new file mode 100644 index 00000000..e69de29b diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss index 3466c406..84028a91 100644 --- a/collects/tests/framework/framework-test-engine.ss +++ b/collects/tests/framework/framework-test-engine.ss @@ -1,33 +1,33 @@ (thread - (letrec ([namespace (make-namespace)] - [_ (parameterize ([current-namespace namespace]) - (require-library "pconvert.ss"))] - [restart - (lambda () - (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))] - [(continue) (make-semaphore 0)] - [(error) #f] - [(answer) (void)]) - (let loop () - (let ([sexp (read in)]) - (if (eof-object? sexp) - (begin - (close-input-port in) - (close-output-port out) - (exit)) - (begin - (queue-callback (lambda () - (set! error #f) - (with-handlers ([(lambda (x) #t) - (lambda (exn) - (set! error exn))]) - (set! answer (eval sexp))) - (semaphore-post continue))) - (semaphore-wait continue) - (write - (if error - (list 'error (exn-message error)) - (list 'normal answer)) - out) - (loop)))))))]) - restart)) + (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)] + [(error) #f] + [(answer) (void)]) + (let loop () + (let ([sexp (read in)]) + (if (eof-object? sexp) + (begin + (close-input-port in) + (close-output-port out) + (exit)) + (begin + (queue-callback (lambda () + (set! error #f) + (with-handlers ([(lambda (x) #t) + (lambda (exn) + (set! error exn))]) + (set! answer (eval sexp))) + (semaphore-post continue))) + (semaphore-wait continue) + (write + (if error + (list 'error (exn-message error)) + (list 'normal (print-convert answer))) + out) + (loop))))))))) diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss new file mode 100644 index 00000000..e3e4f969 --- /dev/null +++ b/collects/tests/framework/main.ss @@ -0,0 +1,131 @@ +(require-library "launcher.ss" "launcher") +(require-library "function.ss") +(require-library "macro.ss") + +;; old, hopefully unnecessary +'(case (system-type) + [(macos) + + (when running? + (let ([tmp-file (build-path (find-system-path 'temp-dir) + "frameworkempty.ss")]) + (call-with-output-file tmp-file + (lambda (port) + (newline port)) + 'truncate) + (send-event "MrEd" "aevt" "quit") + (let loop () + (sleep 1) + (with-handlers ([(lambda (x) #t) void]) + (printf "looping~n") + (send-event "MrEd" "aevt" "odoc" (vector 'file tmp-file)) + (loop))))) + (printf "macos: mred no longer running~n")]) + +(unless (file-exists? "receive-sexps-port.ss") + (call-with-output-file "receive-sexps-port.ss" + (lambda (port) + (write 6012 port)))) + +(define-values (shutdown-listener shutdown-mred send-sexp-to-mred) + (let ([listener + (let loop () + (let ([port (load-relative "receive-sexps-port.ss")]) + (with-handlers ([(lambda (x) #t) + (lambda (x) + (let ([next (+ port 1)]) + (call-with-output-file "receive-sexps-port.ss" + (lambda (p) + (write next p)) + 'truncate) + (printf "tcp-listen failed for port ~a, attempting ~a~n" + port next) + (loop)))]) + (tcp-listen port))))] + [in-port #f] + [out-port #f]) + (let ([restart-mred + (lambda () + (shutdown-mred) + (let-values ([(base _1 _2) (split-path program)]) + ((case (system-type) + [(macos) system*] + [else (lambda (x) (begin (process* x) (void)))]) + (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")))]) + (values + (lambda () + (shutdown-mred) + (tcp-close listener)) + (lambda () + (when (and in-port + out-port) + (close-output-port out-port) + (close-input-port in-port) + (set! in-port #f) + (set! in-port #f))) + (lambda (sexp) + (unless (and in-port out-port) + (restart-mred)) + (write sexp out-port) + (newline out-port) + (let ([answer + (with-handlers ([(lambda (x) #t) + (lambda (x) (list 'cant-read + (string-append + (exn-message x) + "; rest of string: " + (apply + string + (let loop () + (if (char-ready? in-port) + (cons (read-char in-port) + (loop)) + null))))))]) + (read in-port))]) + (unless (and (list? answer) + (= 2 (length answer))) + (error 'framework-test-suite "unpected result from mred: ~s~n" answer)) + (case (car answer) + [(error) (error 'mred (second answer))] + [(cant-read) (error 'mred/cant-parse (second answer))] + [(normal) (second answer)]))))))) + +(define section-jump void) + +(define test + (opt-lambda (test-name failed? test [jump 'section]) + (let ([failed + (with-handlers ([(lambda (x) #t) + (lambda (x) + (if (exn? x) + (exn-message x) + x))]) + (failed? (eval (send-sexp-to-mred test))))]) + (when failed + (printf "FAILED ~a: ~a~n" test-name failed) + (case jump + [(section) (section-jump)] + [(continue) (void)] + [else (jump)]))))) + +(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))))) + (if (equal? (vector) argv) + all-files + (vector->list argv)))) + +(shutdown-listener) diff --git a/collects/tests/framework/prefs.ss b/collects/tests/framework/prefs.ss new file mode 100644 index 00000000..3e15ab2b --- /dev/null +++ b/collects/tests/framework/prefs.ss @@ -0,0 +1,33 @@ +(local [(define pref-file (build-path (find-system-path 'pref-dir) ".mred.prefs")) + (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 pref-sym 'framework:test-suite)] + + (call-with-output-file pref-file + (lambda (port) (write (filter (lambda (x) (not (eq? (car x) pref-sym))) + old-prefs) + port)) + 'truncate) + (shutdown-mred) + (test + 'preference-unbound + (check-eq? "couldn't remove preference binding" '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) + `(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) + `(begin (preferences:set ',pref-sym 'new-pref) + (preferences:get ',pref-sym))) + (send-sexp-to-mred '(exit:exit)) + (shutdown-mred) + (test 'preference-get-after-restart + (check-eq? "get after restart didn't work" 'new-pref) + `(preferences:get ',pref-sym)))