...

original commit: 49956295b384ba589417806cfc57d0889f54a76b

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])

collects/framework/text.ss

@@ -453,18 +453,18 @@
 	[after-set-position
 	 (lambda ()
 	   (super-after-set-position)
-	   (enqueue-for-frame 'edit-position-changed
+	   (enqueue-for-frame 'editor-position-changed
-			      'framework:edit-position-changed))]
+			      'framework:editor-position-changed))]
 	[after-insert
 	 (lambda (start len)
 	   (super-after-insert start len)
-	   (enqueue-for-frame 'edit-position-changed
+	   (enqueue-for-frame 'editor-position-changed
-			      'framework:edit-position-changed))]
+			      'framework:editor-position-changed))]
 	[after-delete
 	 (lambda (start len)
 	   (super-after-delete start len)
-	   (enqueue-for-frame 'edit-position-changed
+	   (enqueue-for-frame 'editor-position-changed
-			      'framework:edit-position-changed))])
+			      'framework:editor-position-changed))])
       (sequence
 	(apply super-init args))))
 

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

collects/tests/framework/text.ss

@@ -8,16 +8,7 @@
 		   (override
 		    [get-editor% (lambda () ,class)]))]
 	      [f (make-object % "test text")])
-	 
+	 (send f show #t)))
-	 (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))))
       (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)))