diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index d1f8aaa4..710641e4 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -10,6 +10,7 @@ [exit : framework:exit^] [finder : framework:finder^] [keymap : framework:keymap^] + [text : framework:text^] [mzlib:function : mzlib:function^]) (rename [-editor<%> editor<%>] @@ -79,6 +80,7 @@ get-canvas% get-editor% + get-editor<%> make-editor save-as get-canvas @@ -132,7 +134,17 @@ (public [get-canvas% (lambda () editor-canvas%)] [get-editor% (lambda () (error 'editor-frame% "no editor% class specified"))] - [make-editor (lambda () (make-object (get-editor%)))]) + [get-editor<%> (lambda () editor<%>)] + [make-editor (lambda () + (let ([% (get-editor%)] + [<%> (get-editor<%>)]) + (unless (implementation? % <%>) + (let ([name (inferred-name this)]) + (error (or name 'frame:editor%) + "result of get-editor% method must match ~e class; got: ~e" + % <%>))) + (make-object %)))]) + (public [save-as @@ -267,6 +279,7 @@ (define text-mixin (mixin (-editor<%>) (-text<%>) args (override + [get-editor<%> (lambda () text<%>)] [get-editor% (lambda () text%)]) (sequence (apply super-init args)))) @@ -274,6 +287,7 @@ (define pasteboard-mixin (mixin (-editor<%>) (-pasteboard<%>) args (override + [get-editor<%> (lambda () pasteboard<%>)] [get-editor% (lambda () pasteboard%)]) (sequence (apply super-init args)))) @@ -436,6 +450,7 @@ (private [super-root 'unitiaialized-super-root]) (override + [get-editor<%> (lambda () text:searching<%>)] [edit-menu:find (lambda (menu evt) (search))]) (override [make-root-area-container @@ -689,6 +704,9 @@ (set! rest-panel r-root) r-root))]) + (override + [get-editor<%> (lambda () text:info<%>)]) + (public [determine-width (let ([magic-space 25]) diff --git a/collects/framework/text.ss b/collects/framework/text.ss index 84cc0295..0d8fd32e 100644 --- a/collects/framework/text.ss +++ b/collects/framework/text.ss @@ -453,18 +453,18 @@ [after-set-position (lambda () (super-after-set-position) - (enqueue-for-frame 'edit-position-changed - 'framework:edit-position-changed))] + (enqueue-for-frame 'editor-position-changed + 'framework:editor-position-changed))] [after-insert (lambda (start len) (super-after-insert start len) - (enqueue-for-frame 'edit-position-changed - 'framework:edit-position-changed))] + (enqueue-for-frame 'editor-position-changed + 'framework:editor-position-changed))] [after-delete (lambda (start len) (super-after-delete start len) - (enqueue-for-frame 'edit-position-changed - 'framework:edit-position-changed))]) + (enqueue-for-frame 'editor-position-changed + 'framework:editor-position-changed))]) (sequence (apply super-init args)))) diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss index da8a3076..95dd771f 100644 --- a/collects/tests/framework/load.ss +++ b/collects/tests/framework/load.ss @@ -21,6 +21,7 @@ pred '(parameterize ([current-namespace (make-namespace 'mred)]) (require-library "tests.ss" "framework") + (require-library "mred-interfaces.ss" "framework") (eval '(invoke-open-unit/sig (compound-unit/sig @@ -40,6 +41,13 @@ (global-defined-value 'test:run-one) (global-defined-value 'test:button-push) (void))) + (test + 'mred-interfacess.ss + pred + '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "mred-interfacess.ss" "framework") + (global-defined-value 'mred-interfaces^) + (void))) (test 'mred-interfaces.ss pred @@ -66,6 +74,7 @@ pred '(parameterize ([current-namespace (make-namespace 'mred)]) (require-library "frameworks.ss" "framework") + (require-library "mred-interfaces.ss" "framework") (eval '(invoke-open-unit/sig (compound-unit/sig diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss index 152050c5..ae623ae6 100644 --- a/collects/tests/framework/text.ss +++ b/collects/tests/framework/text.ss @@ -8,16 +8,7 @@ (override [get-editor% (lambda () ,class)]))] [f (make-object % "test text")]) - - (let loop ([f f][l " "]) - (printf "~a~a ~a~n" l f (send f get-label)) - (when (is-a? f area-container<%>) - (for-each (lambda (c) - (loop c (string-append " " l))) - (send f get-children)))) - (send f show #t) - (sleep/yield 1) - (printf "focus: ~a~n" (get-top-level-focus-window)))) + (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)))