diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 4746ae87..90e10efb 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -3,7 +3,7 @@ (lib "mred.ss" "mred") (lib "mred-sig.ss" "mred") - (prefix test: "test.ss") + "test.ss" "test-sig.ss" (prefix prefs-file: "prefs-file.ss") diff --git a/collects/framework/private/exit.ss b/collects/framework/private/exit.ss index ad9d3763..f9b3764f 100644 --- a/collects/framework/private/exit.ss +++ b/collects/framework/private/exit.ss @@ -69,4 +69,4 @@ (when (can-exit?) (on-exit) (queue-callback (lambda () (exit)))) - (set! exiting? #f)))))) \ No newline at end of file + (set! exiting? #f)))))) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 625fb8c2..7399fa3a 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -143,7 +143,7 @@ (super-instantiate ()) (accept-drop-files #t) - (make-object menu% "&Window" (make-object (get-menu-bar%) this)) + (make-object menu% "&Windows" (make-object (get-menu-bar%) this)) (reorder-menus this) (send (group:get-the-frame-group) insert-frame this) [define panel (make-root-area-container (get-area-container%) this)] @@ -583,7 +583,7 @@ (define editor-mixin (mixin (standard-menus<%>) (-editor<%>) - (init file-name) + (init (file-name #f)) (inherit get-area-container get-client-size show get-edit-target-window get-edit-target-object) diff --git a/collects/framework/private/gen-standard-menus.ss b/collects/framework/private/gen-standard-menus.ss index 4d210a12..df4d2dee 100644 --- a/collects/framework/private/gen-standard-menus.ss +++ b/collects/framework/private/gen-standard-menus.ss @@ -69,11 +69,11 @@ (instantiate (get-menu-item%) () (label ,(join menu-before-string menu-after-string `(,(an-item->string-name item)))) - (parent ,(menu-item-menu-name item)) + (menu ,(menu-item-menu-name item)) (callback (let ([,callback-name (lambda (item evt) (,callback-name item evt))]) ,callback-name)) (shortcut ,key) - (help (,(an-item->help-string-name item))) + (help-string (,(an-item->help-string-name item))) (demand-callback (lambda (menu-item) (,(an-item->on-demand-name item) menu-item))))))))) ;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause)) @@ -187,4 +187,4 @@ (reorder-menus this))) port)) 'text - 'truncate)) \ No newline at end of file + 'truncate)) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 5918f5be..064423a7 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -150,6 +150,15 @@ #f]) #f))) (scheme-paren:get-comments)))) + + + (rename [super-on-close on-close]) + (override on-close) + (define (on-close) + (remove-indents-callback) + (remove-paren-callback) + (super-on-close)) + (define remove-indents-callback (preferences:add-callback 'framework:tabify @@ -1038,4 +1047,4 @@ (reset lambda-list-box lambda-keywords) #t))]) (preferences:add-callback 'framework:tabify (lambda (p v) (update-list-boxes v))) - main-panel)))))))) \ No newline at end of file + main-panel)))))))) diff --git a/collects/framework/test.ss b/collects/framework/test.ss index baec53ed..61c9e9bf 100644 --- a/collects/framework/test.ss +++ b/collects/framework/test.ss @@ -5,9 +5,12 @@ (lib "mred-sig.ss" "mred") (lib "mred.ss" "mred")) - (provide-signature-elements framework:test^) + (provide-signature-elements ((unit test : framework:test^))) - (define-values/invoke-unit/sig framework:test^ - framework:test@ + (define-values/invoke-unit/sig ((unit test : framework:test^)) + (compound-unit/sig + (import [m : mred^]) + (link [test : framework:test^ (framework:test@ m)]) + (export (unit test))) #f - mred^)) \ No newline at end of file + mred^)) diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 9ac01cfa..d43da532 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -114,5 +114,3 @@ test as last time, or `all' to run all of the tests. |#) - -`(load.ss) diff --git a/collects/tests/framework/canvas.ss b/collects/tests/framework/canvas.ss index ec167c95..6dd251bf 100644 --- a/collects/tests/framework/canvas.ss +++ b/collects/tests/framework/canvas.ss @@ -1,7 +1,10 @@ +(module canvas mzscheme + (require "test-suite-utils.ss") + (define (test-creation class name) (test name - (lambda (x) #t) + (lambda (x) (eq? 'passed x)) (lambda () (send-sexp-to-mred `(let* ([f (make-object frame:basic% "test canvas" #f 300 300)] @@ -10,7 +13,8 @@ (send f show #t))) (wait-for-frame "test canvas") (send-sexp-to-mred - `(send (get-top-level-focus-window) show #f))))) + `(send (get-top-level-focus-window) show #f)) + 'passed))) (test-creation '(canvas:basic-mixin editor-canvas%) 'canvas:basic-mixin-creation) @@ -21,3 +25,4 @@ 'canvas:wide-snip-mixin-creation) (test-creation 'canvas:wide-snip% 'canvas:wide-snip%-creation) +) diff --git a/collects/tests/framework/debug.ss b/collects/tests/framework/debug.ss index 48d4ee95..47eaf9f3 100644 --- a/collects/tests/framework/debug.ss +++ b/collects/tests/framework/debug.ss @@ -1,44 +1,50 @@ (module debug mzscheme (provide debug-printf debug-when) - ;; all of the steps in the tcp connection - (define tcp? #f) + (define-syntax debug-when + (lambda (stx) - ;; administrative messages about preferences files and - ;; command line flags - (define admin? #f) + ;; all of the steps in the tcp connection + (define mz-tcp? #f) + (define mr-tcp? mz-tcp?) + + ;; administrative messages about preferences files and + ;; command line flags + (define admin? #f) + + ;; tests that passed and those that failed + (define schedule? #t) + + ;; of the sexpression transactions between mz and mred + (define messages? #t) - ;; tests that passed and those that failed - (define schedule? #t) - - ;; of the sexpression transactions between mz and mred - (define messages? #t) + (syntax-case stx (mr-tcp mz-tcp admin schedule messages) + [(_ mr-tcp rest ...) + (if mr-tcp? + (syntax (begin rest ...)) + (syntax (void)))] + [(_ mz-tcp rest ...) + (if mz-tcp? + (syntax (begin rest ...)) + (syntax (void)))] + [(_ admin rest ...) + (if admin? + (syntax (begin rest ...)) + (syntax (void)))] + [(_ schedule rest ...) + (if schedule? + (syntax (begin rest ...)) + (syntax (void)))] + [(_ messages rest ...) + (if messages? + (syntax (begin rest ...)) + (syntax (void)))] + [(_ unk rest ...) + (raise-syntax-error 'debug-when "unknown flag" stx (syntax unk))]))) (define-syntax debug-printf (lambda (stx) (syntax-case stx () [(_ flag fmt-string rest ...) (with-syntax ([flag-name (format ">> ~a: " (syntax-object->datum (syntax flag)))]) - (syntax (debug-when flag (printf (string-append flag-name fmt-string) rest ...))))]))) - - (define-syntax debug-when - (lambda (stx) - (syntax-case stx (tcp admin schedule messages) - [(_ tcp rest ...) - (syntax - (when tcp? - rest ...))] - [(_ admin rest ...) - (syntax - (when admin? - rest ...))] - [(_ schedule rest ...) - (syntax - (when schedule? - rest ...))] - [(_ messages rest ...) - (syntax - (when messages? - rest ...))] - [(_ unk rest ...) - (raise-syntax-error 'debug-when "unknown flag" stx (syntax unk))])))) + (syntax (debug-when flag (printf (string-append flag-name fmt-string) rest ...))))])))) diff --git a/collects/tests/framework/exit.ss b/collects/tests/framework/exit.ss index 992c0f49..3a77229f 100644 --- a/collects/tests/framework/exit.ss +++ b/collects/tests/framework/exit.ss @@ -1,3 +1,6 @@ +(module exit mzscheme + (require "test-suite-utils.ss") + (test 'exit/no-prompt (lambda (x) (and (eq? x 'passed) @@ -99,3 +102,4 @@ (with-handlers ([eof-result? (lambda (x) 'passed)]) (send-sexp-to-mred `(exit:exit)))))) +) diff --git a/collects/tests/framework/frame.ss b/collects/tests/framework/frame.ss index 5b0013e5..ca94ded7 100644 --- a/collects/tests/framework/frame.ss +++ b/collects/tests/framework/frame.ss @@ -1,50 +1,69 @@ -(define (test-creation name class-expression) +(module frame mzscheme + (require "test-suite-utils.ss") + +(define (test-creation name class-expression . args) (test name - (lambda (x) x) + (lambda (x) (eq? 'passed x)) (lambda () - (send-sexp-to-mred - `(begin (preferences:set 'framework:exit-when-no-frames #f) - (send (make-object ,class-expression "test") show #t))) - (wait-for-frame "test") - (queue-sexp-to-mred - '(send (get-top-level-focus-window) close)) - #t))) + (let ([frame-label + (send-sexp-to-mred + `(let ([f (instantiate ,class-expression () ,@args)]) + (preferences:set 'framework:exit-when-no-frames #f) + (send f show #t) + (send f get-label)))]) + (wait-for-frame frame-label) + (queue-sexp-to-mred + '(send (get-top-level-focus-window) close)) + 'passed)))) (test-creation 'basic%-creation - 'frame:basic%) + 'frame:basic% + '(label "test")) (test-creation 'basic-mixin-creation - '(frame:basic-mixin frame%)) + '(frame:basic-mixin frame%) + '(label "test")) (test-creation 'info-mixin-creation - '(frame:info-mixin frame:basic%)) + '(frame:info-mixin frame:basic%) + '(label "test")) + (test-creation 'info%-creation - 'frame:info%) + 'frame:info% + '(label "test")) (test-creation 'text-info-mixin-creation - '(frame:text-info-mixin frame:info%)) + '(frame:text-info-mixin frame:info%) + '(label "test")) (test-creation 'text-info%-creation - 'frame:text-info%) + 'frame:text-info% + '(label "test")) (test-creation 'pasteboard-info-mixin-creation - '(frame:pasteboard-info-mixin frame:info%)) + '(frame:pasteboard-info-mixin frame:info%) + '(label "test")) + (test-creation 'pasteboard-info%-creation - 'frame:pasteboard-info%) + 'frame:pasteboard-info% + '(label "test")) (test-creation 'standard-menus%-creation - 'frame:standard-menus%) + 'frame:standard-menus% + '(label "test")) + (test-creation 'standard-menus-mixin - '(frame:standard-menus-mixin frame:basic%)) + '(frame:standard-menus-mixin frame:basic%) + '(label "test")) (test-creation 'text%-creation @@ -95,15 +114,18 @@ (test name (lambda (x) - (delete-file tmp-file) + (when (file-exists? tmp-file) + (delete-file tmp-file)) (equal? x test-file-contents)) (lambda () - (send-sexp-to-mred - `(begin - (preferences:set 'framework:exit-when-no-frames #f) - (preferences:set 'framework:file-dialogs 'common) - (send (make-object ,class-expression "test open") show #t))) - (wait-for-frame "test open") + (let ([frame-name + (send-sexp-to-mred + `(let ([frame (instantiate ,class-expression ())]) + (preferences:set 'framework:exit-when-no-frames #f) + (preferences:set 'framework:file-dialogs 'common) + (send frame show #t) + (send frame get-label)))]) + (wait-for-frame frame-name) (send-sexp-to-mred `(test:menu-select "File" "Open...")) (wait-for-frame "Get file") @@ -128,37 +150,10 @@ [t (send (send w get-editor) get-text)]) (test:close-top-level-window w) t)) - (wait-for-frame "test open") + (wait-for-frame frame-name) (queue-sexp-to-mred - `(send (get-top-level-focus-window) close))))))) + `(send (get-top-level-focus-window) close)))))))) (test-open "frame:editor open" 'frame:text%) (test-open "frame:searchable open" 'frame:searchable%) -(test-open "frame:text-info open" 'frame:text-info-file%) - -(test - "set!-ing menu callback in standard-menus-frame" - (lambda (x) (eq? x 'passed)) - (lambda () - (send-sexp-to-mred - `(let* ([set!-cb-frame% - (class frame:standard-menus% () - (private [value 'failed]) - (public - [get-value - (lambda () value)] - [update-printing-proc - (lambda () - (set! file-menu:print - (lambda x (set! value 'passed))))]) - (override - [file-menu:print (lambda x (void))]) - (sequence (super-init "set!-cb frame")))] - [f (make-object set!-cb-frame%)]) - (send f update-printing-proc) - (send f show #t))) - (wait-for-frame "set!-cb frame") - (send-sexp-to-mred - `(test:menu-select "File" "Print...")) - (send-sexp-to-mred - `(send (get-top-level-focus-window) get-value)))) +(test-open "frame:text-info open" 'frame:text-info-file%)) diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss index 941e9049..4f084f29 100644 --- a/collects/tests/framework/framework-test-engine.ss +++ b/collects/tests/framework/framework-test-engine.ss @@ -1,11 +1,9 @@ -(require (lib "errortrace.ss" "errortrace")) +;(require (lib "errortrace.ss" "errortrace")) (module framework-test-engine mzscheme (require (lib "pconvert.ss") (lib "mred.ss" "mred") - (lib "errortrace.ss" "errortrace") - "debug.ss" - ) + "debug.ss") (define errs null) (define sema (make-semaphore 1)) @@ -16,43 +14,50 @@ (define (exception->string x) (if (exn? x) -; (let ([p (open-output-string)]) -; (print-error-trace p x) -; (string-append (exn-message x) (string #\newline) (get-output-string p))) - (exn-message x) - (format "~s" x))) + (let ([p (open-output-string)]) + (parameterize ([current-error-port p]) + ((error-display-handler) (exn-message x) x)) + (get-output-string p)) + (format "uncaught exn: ~s" x))) (thread (lambda () - (let ([port (load - (build-path - (collection-path "tests" "framework") - "receive-sexps-port.ss"))]) - (debug-printf tcp "about to connect to ~a~n" port) - (let*-values ([(in out) (tcp-connect "127.0.0.1" port)]) - (let loop () - (debug-printf tcp "about to read~n") - (let ([sexp (read in)]) - (debug-printf tcp "got something~n") - (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 (x) (list 'error (exception->string x)))]) - (list 'normal (print-convert (eval sexp)))) - (list 'error - (apply string-append - (map (lambda (x) (string-append (exception->string x) (string #\newline))) - these-errs))))) - out) - (loop))))))))) - + (with-handlers ([(lambda (x) #t) + (lambda (x) + (printf "test suite thread died: ~a~n" + (if (exn? x) + (exn-message x) + (format "~s" x))))]) + (let ([port (load + (build-path + (collection-path "tests" "framework") + "receive-sexps-port.ss"))]) + (debug-printf mr-tcp "about to connect to ~a~n" port) + (let*-values ([(in out) (tcp-connect "127.0.0.1" port)]) + (let loop () + (debug-printf mr-tcp "about to read~n") + (let ([sexp (read in)]) + (if (eof-object? sexp) + (begin + (debug-printf mr-tcp "got eof~n") + (close-input-port in) + (close-output-port out) + (exit)) + (begin + (debug-printf mr-tcp "got expression to evaluate~n") + (write + (let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))]) + (if (null? these-errs) + (with-handlers ([not-break-exn? + (lambda (x) (list 'error (exception->string x)))]) + (list 'normal (print-convert (eval sexp)))) + (list 'last-error + (apply string-append + (map (lambda (x) (string-append (exception->string x) (string #\newline))) + these-errs))))) + out) + (loop)))))))))) + (let ([od (event-dispatch-handler)] [port (current-output-port)]) (event-dispatch-handler diff --git a/collects/tests/framework/group-test.ss b/collects/tests/framework/group-test.ss index 914f67a8..fb6b8e0b 100644 --- a/collects/tests/framework/group-test.ss +++ b/collects/tests/framework/group-test.ss @@ -1,3 +1,6 @@ +(module group-test mzscheme + (require "test-suite-utils.ss") + (test 'exit-off (lambda (x) (not (equal? x "test"))) @@ -140,3 +143,5 @@ (for-each (lambda (x) (send x close)) frames)))))) + +) diff --git a/collects/tests/framework/handler-test.ss b/collects/tests/framework/handler-test.ss index f5b5b534..a6e79334 100644 --- a/collects/tests/framework/handler-test.ss +++ b/collects/tests/framework/handler-test.ss @@ -1,3 +1,6 @@ +(module handler-test mzscheme + (require "test-suite-utils.ss") + (let* ([filename "framework-group-test.ss"] [tmp-filename (build-path (find-system-path 'temp-dir) filename)]) @@ -39,4 +42,6 @@ (wait-for-frame filename) (send-sexp-to-mred `(let ([f (car (get-top-level-windows))]) - (send (send f get-editor) get-filename)))))) \ No newline at end of file + (send (send f get-editor) get-filename)))))) + +) diff --git a/collects/tests/framework/keys.ss b/collects/tests/framework/keys.ss index e207d7d0..eb689c46 100644 --- a/collects/tests/framework/keys.ss +++ b/collects/tests/framework/keys.ss @@ -1,3 +1,6 @@ +(module keys mzscheme + (require "test-suite-utils.ss") + (test 'keymap:aug-keymap%/get-table (lambda (x) @@ -121,3 +124,5 @@ (scheme:text-mixin text:basic%))]) (sequence (super-init name))) scheme-specs) + +) diff --git a/collects/tests/framework/mem.ss b/collects/tests/framework/mem.ss index 43d56834..20fa6f87 100644 --- a/collects/tests/framework/mem.ss +++ b/collects/tests/framework/mem.ss @@ -1,4 +1,7 @@ -;; mem-boxes : (list-of (list string (list-of (weak-box TST)))) +(module mem mzscheme + (require "test-suite-utils.ss") + +; mem-boxes : (list-of (list string (list-of (weak-box TST)))) (send-sexp-to-mred '(define mem-boxes null)) (define mem-count 10) @@ -32,13 +35,17 @@ [anything? #f]) (for-each (lambda (boxl) - (let* ([tag (first boxl)] - [boxes (second boxl)] + (let* ([tag (car boxl)] + [boxes (cadr boxl)] [calc-results (lambda () - (foldl (lambda (b n) (if (weak-box-value b) (+ n 1) n)) - 0 - boxes))]) + (let loop ([boxes boxes] + [n 0]) + (cond + [(null? boxes) n] + [else (if (weak-box-value (car boxes)) + (loop (cdr boxes) (+ n 1)) + (loop (cdr boxes) n))])))]) (let loop ([tries 16]) (unless (zero? tries) (when (> (calc-results) 0) @@ -117,3 +124,4 @@ ;(test-frame-allocate 'frame:pasteboard%) ;(test-frame-allocate 'frame:pasteboard-info-file%) (done) +) diff --git a/collects/tests/framework/panel.ss b/collects/tests/framework/panel.ss index 3079a341..044f69c7 100644 --- a/collects/tests/framework/panel.ss +++ b/collects/tests/framework/panel.ss @@ -1,61 +1,66 @@ +(module panel mzscheme + (require "test-suite-utils.ss") + (test 'single-panel (lambda (x) (eq? x 'passed)) `(let* ([semaphore (make-semaphore 0)] [semaphore-frame% - (class frame% args - (override - [on-close (lambda () (semaphore-post semaphore))]) - (sequence - (apply super-init args)))] + (class frame% + (override on-close) + [define on-close (lambda () (semaphore-post semaphore))] + (super-instantiate ()))] [f (make-object semaphore-frame% "Single Panel Test")] [blue-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)] [green-brush (send the-brush-list find-or-create-brush "FOREST GREEN" 'solid)] [black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)] [grid-canvas% - (class canvas% (lines parent label stretchable-width? stretchable-height?) + (class canvas% + (init-field lines) + (init label) (inherit get-dc get-client-size) - (override - [on-paint - (lambda () - (let-values ([(width height) (get-client-size)]) - (let ([dc (get-dc)] - [single-width (/ width lines)] - [single-height (/ height lines)]) - (send dc set-pen black-pen) - (let loop ([i lines]) - (cond - [(zero? i) (void)] - [else - (let loop ([j lines]) - (cond - [(zero? j) (void)] - [else - (send dc set-brush - (if (= 0 (modulo (+ i j) 2)) - blue-brush green-brush)) - (send dc draw-rectangle - (* single-width (- i 1)) - (* single-height (- j 1)) - single-width - single-height) - (loop (- j 1))])) - (loop (- i 1))])))))]) - (inherit set-label min-width min-height stretchable-height stretchable-width) - (sequence - (super-init parent) - (stretchable-width stretchable-width?) - (stretchable-height stretchable-height?) - (min-width 50) - (min-height 50) - (set-label label)))] - + (override on-paint) + (define (on-paint) + (let-values ([(width height) (get-client-size)]) + (let ([dc (get-dc)] + [single-width (/ width lines)] + [single-height (/ height lines)]) + (send dc set-pen black-pen) + (let loop ([i lines]) + (cond + [(zero? i) (void)] + [else + (let loop ([j lines]) + (cond + [(zero? j) (void)] + [else + (send dc set-brush + (if (= 0 (modulo (+ i j) 2)) + blue-brush green-brush)) + (send dc draw-rectangle + (* single-width (- i 1)) + (* single-height (- j 1)) + single-width + single-height) + (loop (- j 1))])) + (loop (- i 1))]))))) + (super-instantiate ()) + + ;; soon to be obsolete, hopefully. + (inherit set-label) + (set-label label) + + (inherit min-width min-height) + (min-width 50) + (min-height 50))] [border-panel (make-object horizontal-panel% f '(border))] [single-panel (make-object panel:single% border-panel)] - [children (list (make-object grid-canvas% 3 single-panel "Small" #f #f) - (make-object grid-canvas% 3 single-panel "Wide" #f #t) - (make-object grid-canvas% 3 single-panel "Tall" #t #f) - (make-object grid-canvas% 3 single-panel "Wide and Tall" #t #t))] + [children + (list + (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f)) + (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide") (stretchable-width #f) (stretchable-height #t)) + (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Tall") (stretchable-width #t) (stretchable-height #f)) + (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))] [active-child (car children)] [radios (make-object horizontal-panel% f)] [make-radio @@ -128,3 +133,4 @@ (yield semaphore) (send f show #f) result)) +) diff --git a/collects/tests/framework/pasteboard.ss b/collects/tests/framework/pasteboard.ss index f4f49de0..59a0d3c9 100644 --- a/collects/tests/framework/pasteboard.ss +++ b/collects/tests/framework/pasteboard.ss @@ -1,20 +1,24 @@ +(module pasteboard mzscheme + (require "test-suite-utils.ss") + (define (test-creation frame class name) (test name (lambda (x) #t) (lambda () - (send-sexp-to-mred - `(let* ([% (class-asi ,frame - (override - [get-editor% - (lambda () - ,class)]))] - [f (make-object % "test pasteboard")]) - (preferences:set 'framework:exit-when-no-frames #f) - (send f show #t))) - (wait-for-frame "test pasteboard") - (queue-sexp-to-mred - `(send (get-top-level-focus-window) close))))) + (let ([frame-label + (send-sexp-to-mred + `(let* ([% (class ,frame + (override get-editor%) + [define (get-editor%) + ,class])] + [f (instantiate % ())]) + (preferences:set 'framework:exit-when-no-frames #f) + (send f show #t) + (send f get-label)))]) + (wait-for-frame frame-label) + (queue-sexp-to-mred + `(send (get-top-level-focus-window) close)))))) (test-creation 'frame:editor% '(editor:basic-mixin pasteboard%) @@ -43,3 +47,4 @@ (test-creation 'frame:pasteboard% 'pasteboard:info% 'pasteboard:info-creation) +) diff --git a/collects/tests/framework/prefs.ss b/collects/tests/framework/prefs.ss index df1d1593..7a1ae512 100644 --- a/collects/tests/framework/prefs.ss +++ b/collects/tests/framework/prefs.ss @@ -1,3 +1,9 @@ +(module prefs mzscheme + (require "test-suite-utils.ss" + (lib "etc.ss") + (lib "list.ss")) + + (local [(define pref-file (build-path (find-system-path 'pref-dir) (case (system-type) [(macos) "MrEd Preferences"] @@ -34,7 +40,14 @@ (preferences:get ',pref-sym))) (with-handlers ([eof-result? (lambda (x) (void))]) - (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f) (exit:exit)))) + (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f) + (exit:exit) + + ;; do this yield here so that exit:exit + ;; actually exits on this interaction. + ;; right now, exit:exit queue's a new event to exit + ;; instead of just exiting immediately. + (yield (make-semaphore 0))))) (test 'preference-get-after-restart (check-eq? 'new-pref) @@ -45,7 +58,8 @@ (test 'dialog-appears (lambda (x) (eq? 'passed x)) (lambda () - (send-sexp-to-mred '(preferences:show-dialog)) + (send-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t) + (preferences:show-dialog))) (wait-for-frame "Preferences") (send-sexp-to-mred '(begin (preferences:hide-dialog) (let ([f (get-top-level-focus-window)]) @@ -54,3 +68,5 @@ 'failed 'passed) 'passed)))))) +) + diff --git a/collects/tests/framework/scheme.ss b/collects/tests/framework/scheme.ss deleted file mode 100644 index e69de29b..00000000 diff --git a/collects/tests/framework/test-suite-utils.ss b/collects/tests/framework/test-suite-utils.ss index 7c7e3722..bb9b6035 100644 --- a/collects/tests/framework/test-suite-utils.ss +++ b/collects/tests/framework/test-suite-utils.ss @@ -63,39 +63,37 @@ (define listener (let loop () (let ([port (load port-filename)]) - (with-handlers ([(lambda (x) #t) + (with-handlers ([not-break-exn? (lambda (x) (let ([next (+ port 1)]) (call-with-output-file port-filename (lambda (p) (write next p)) 'truncate) - (debug-printf tcp " tcp-listen failed for port ~a, attempting ~a~n" + (debug-printf mz-tcp " tcp-listen failed for port ~a, attempting ~a~n" port next) (loop)))]) - (debug-printf tcp "listening to ~a~n" port) + (debug-printf mz-tcp "listening to ~a~n" port) (tcp-listen port))))) (define in-port #f) (define out-port #f) - (define restart-mred - (lambda () - (shutdown-mred) - ((case (system-type) - [(macos) system*] - [else (lambda (x) (thread (lambda () (system* x))))]) - (mred-program-launcher-path "Framework Test Engine")) - (debug-printf tcp "accepting listener~n") - (let-values ([(in out) (tcp-accept listener)]) - (set! in-port in) - (set! out-port out)) - (when load-framework-automatically? - (queue-sexp-to-mred - `(begin - (require (lib "framework.ss" "framework") - (lib "gui.ss" "tests" "utils"))))))) + (define (restart-mred) + (shutdown-mred) + ((case (system-type) + [(macos) system*] + [else (lambda (x) (thread (lambda () (system* x))))]) + (mred-program-launcher-path "Framework Test Engine")) + (debug-printf mz-tcp "accepting listener~n") + (let-values ([(in out) (tcp-accept listener)]) + (set! in-port in) + (set! out-port out)) + (when load-framework-automatically? + (queue-sexp-to-mred + '(begin (eval '(require (lib "framework.ss" "framework"))) + (eval '(require (lib "gui.ss" "tests" "utils"))))))) (define load-framework-automatically (case-lambda @@ -109,16 +107,16 @@ (define shutdown-listener (lambda () (shutdown-mred) - (debug-printf tcp "closing listener~n") + (debug-printf mz-tcp "closing listener~n") (tcp-close listener))) (define shutdown-mred (lambda () (when (and in-port out-port) - (with-handlers ([(lambda (x) #t) (lambda (x) (void))]) + (with-handlers ([not-break-exn? (lambda (x) (void))]) (close-output-port out-port)) - (with-handlers ([(lambda (x) #t) (lambda (x) (void))]) + (with-handlers ([not-break-exn? (lambda (x) (void))]) (close-input-port in-port)) (set! in-port #f) (set! in-port #f)))) @@ -145,83 +143,84 @@ (or (regexp-match re:tcp-read-error (exn-message exn)) (regexp-match re:tcp-write-error (exn-message exn)))) - (define send-sexp-to-mred - (let ([failed-last-time? #f]) - (lambda (sexp) - (let/ec k - (let ([show-text - (lambda (sexp) - - (debug-when messages - (parameterize ([pretty-print-print-line - (let ([prompt " "] - [old-liner (pretty-print-print-line)]) - (lambda (ln port ol cols) - (let ([ov (old-liner ln port ol cols)]) - (if ln - (begin (display prompt port) - (+ (string-length prompt) ov)) - ov))))]) - (pretty-print sexp) - (newline))))]) - (unless (and in-port - out-port - (with-handlers ([tcp-error? - (lambda (x) #f)]) - (or (not (char-ready? in-port)) - (not (eof-object? (peek-char in-port)))))) - (restart-mred)) - (debug-printf messages " ~a // ~a: sending to mred:~n" section-name test-name) - (show-text sexp) - (with-handlers ([(lambda (x) #t) - (lambda (x) - (cond - ;; this means that mred was closed - ;; so we can restart it and try again. - [(tcp-error? x) - (restart-mred) - (write sexp out-port) - (newline out-port)] - [else (raise x)]))]) - (write sexp out-port) - (newline out-port)) - (let ([answer - (with-handlers ([(lambda (x) #t) - (lambda (x) - (if (tcp-error? x);; assume tcp-error means app closed - eof - (list 'cant-read - (string-append - (exn-message x) - "; rest of string: " - (format - "~s" - (apply - string - (let loop () - (if (char-ready? in-port) - (let ([char (read-char in-port)]) - (if (eof-object? char) - null - (cons char (loop)))) - null))))))))]) - (read in-port))]) - (unless (or (eof-object? answer) - (and (list? answer) - (= 2 (length answer)))) - (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer)) - (if (eof-object? answer) - (raise (make-eof-result)) - (case (car answer) - [(error) - (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))] - [(cant-read) (error 'mred/cant-parse (second answer))] - [(normal) - (debug-printf messages " ~a // ~a: received from mred:~n" section-name test-name) - (show-text (second answer)) - (eval (second answer))])))))))) + (define (send-sexp-to-mred sexp) + (let/ec k + (let ([show-text + (lambda (sexp) + + (debug-when messages + (parameterize ([pretty-print-print-line + (let ([prompt " "] + [old-liner (pretty-print-print-line)]) + (lambda (ln port ol cols) + (let ([ov (old-liner ln port ol cols)]) + (if ln + (begin (display prompt port) + (+ (string-length prompt) ov)) + ov))))]) + (pretty-print sexp) + (newline))))]) + (unless (and in-port + out-port + (with-handlers ([tcp-error? + (lambda (x) #f)]) + (or (not (char-ready? in-port)) + (not (eof-object? (peek-char in-port)))))) + (restart-mred)) + (debug-printf messages " ~a // ~a: sending to mred:~n" section-name test-name) + (show-text sexp) + (with-handlers ([not-break-exn? + (lambda (x) + (cond + ;; this means that mred was closed + ;; so we can restart it and try again. + [(tcp-error? x) + (restart-mred) + (write sexp out-port) + (newline out-port)] + [else (raise x)]))]) + (write sexp out-port) + (newline out-port)) + (let ([answer + (with-handlers ([not-break-exn? + (lambda (x) + (if (tcp-error? x);; assume tcp-error means app closed + eof + (list 'cant-read + (string-append + (exn-message x) + "; rest of string: " + (format + "~s" + (apply + string + (let loop () + (if (char-ready? in-port) + (let ([char (read-char in-port)]) + (if (eof-object? char) + null + (cons char (loop)))) + null))))))))]) + (read in-port))]) + (debug-printf messages " ~a // ~a: received from mred:~n" section-name test-name) + (show-text answer) + (unless (or (eof-object? answer) + (and (list? answer) + (= 2 (length answer)) + (memq (car answer) + '(error last-error cant-read normal)))) + (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer)) + (if (eof-object? answer) + (raise (make-eof-result)) + (case (car answer) + [(error) + (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))] + [(last-error) + (error 'send-sexp-to-mred "mred (last time) raised \"~a\"" (second answer))] + [(cant-read) (error 'mred/cant-parse (second answer))] + [(normal) + (eval (second answer))])))))) - (define test (case-lambda [(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)] @@ -230,7 +229,7 @@ (when (or (not only-these-tests) (memq test-name only-these-tests)) (let* ([result - (with-handlers ([(lambda (x) #t) + (with-handlers ([not-break-exn? (lambda (x) (if (exn? x) (exn-message x) @@ -239,7 +238,14 @@ (sexp/proc) (begin0 (send-sexp-to-mred sexp/proc) (send-sexp-to-mred ''check-for-errors))))] - [failed (not (passed? result))]) + [failed (with-handlers ([not-break-exn? + (lambda (x) + (string-append + "passed? test raised exn: " + (if (exn? x) + (exn-message x) + (format "~s" x))))]) + (not (passed? result)))]) (when failed (debug-printf schedule "FAILED ~a:~n ~s~n" test-name result) (set! failed-tests (cons (cons section-name test-name) failed-tests)) diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss index 2936213d..68f8582b 100644 --- a/collects/tests/framework/text.ss +++ b/collects/tests/framework/text.ss @@ -1,23 +1,30 @@ +(module text mzscheme + (require "test-suite-utils.ss") + (define (test-creation frame% class name) (test name - (lambda (x) #t) + (lambda (x) (eq? x 'passed)) (lambda () - (send-sexp-to-mred - `(let* ([% (class-asi ,frame% - (override - [get-editor% (lambda () ,class)]))] - [f (make-object % "test text")]) - (preferences:set 'framework:exit-when-no-frames #f) - (send f show #t))) - (wait-for-frame "test text") - (send-sexp-to-mred `(test:keystroke #\a)) - (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text))) - (send-sexp-to-mred - `(begin (send (send (get-top-level-focus-window) get-editor) lock #t) - (send (send (get-top-level-focus-window) get-editor) lock #f))) - (queue-sexp-to-mred - `(send (get-top-level-focus-window) close))))) + (let ([label + (send-sexp-to-mred + `(let ([f (instantiate (class ,frame% + (override get-editor%) + [define (get-editor%) ,class] + (super-instantiate ())) + ())]) + (preferences:set 'framework:exit-when-no-frames #f) + (send f show #t) + (send f get-label)))]) + (wait-for-frame label) + (send-sexp-to-mred `(test:keystroke #\a)) + (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text))) + (send-sexp-to-mred + `(begin (send (send (get-top-level-focus-window) get-editor) lock #t) + (send (send (get-top-level-focus-window) get-editor) lock #f))) + (queue-sexp-to-mred + `(send (get-top-level-focus-window) close)) + 'passed)))) (test-creation 'frame:text% @@ -27,17 +34,6 @@ 'text:basic% 'text:basic-creation) -(define (return-args class) - `(class ,class () - (sequence - (super-init void)))) -(test-creation 'frame:text% - (return-args '(text:return-mixin text:basic%)) - 'text:return-mixin-creation) -(test-creation 'frame:text% - (return-args 'text:return%) - 'text:return-creation) - (test-creation 'frame:text% '(editor:file-mixin text:keymap%) 'editor:file-mixin-creation) @@ -67,4 +63,6 @@ 'text:info-mixin-creation) (test-creation '(frame:searchable-mixin frame:text%) 'text:info% - 'text:info-creation) \ No newline at end of file + 'text:info-creation) + +)