..

original commit: 99d4ae8b1373b106a897126bf9a342428531826c

collects/framework/framework.ss

@@ -1195,6 +1195,34 @@
     "@link keymap"
     "with the bindings for searching.")
 
+   (keymap:set-chained-keymaps
+    ((is-a?/c keymap:aug-keymap<%>)
+     (listof (is-a?/c keymap%))
+     . -> .
+     void?)
+    (keymap children-keymaps)
+    "Sets \\var{keymap}'s chained keymaps to \\var{children-keymaps},"
+    "unchaining any keymaps that are currently chained to \\var{keymap}.")
+   
+   (keymap:remove-chained-keymap
+    ((is-a?/c editor<%>)
+     (is-a?/c keymap:aug-keymap<%>)
+     . -> . 
+     void?)
+    (editor keymap)
+    "Removes \\var{keymap} from the keymaps chained to \\var{editor}."
+    "Also (indirectly) removes all keymaps chained to \\var{keymap} from \\var{editor},"
+    "since they are removed when unchaining \\var{keymap} itself."
+    ""
+    "Each of the keymaps chained to \\var{editor} must be an"
+    "@ilink keymap:aug-keymap"
+    "and \\var{keymap} cannot be the result of"
+    "\\begin{schemedisplay}"
+    "(send editor get-keymap)"
+    "\\end{schemedisplay}"
+    "That is, \\var{keymap} must be chained to some keymap attached"
+    "to the editor.")
+    
    (scheme-paren:backward-containing-sexp
     (opt->
      ((is-a?/c text%)

collects/framework/private/keymap.ss

@@ -2,12 +2,11 @@
 (module keymap mzscheme
   (require (lib "string-constant.ss" "string-constants")
            (lib "unitsig.ss")
-	   "sig.ss"
 	   "../macro.ss"
 	   (lib "class.ss")
-	   (lib "class100.ss")
 	   (lib "list.ss")
-	   (lib "mred-sig.ss" "mred"))
+	   (lib "mred-sig.ss" "mred")
+           "sig.ss")
   
   (provide keymap@)
   
@@ -22,7 +21,35 @@
               [editor : framework:editor^])
       
       (rename [-get-file get-file])
+
+      (define (remove-chained-keymap ed keymap-to-remove)
+        (let ([ed-keymap (send ed get-keymap)])
+          (when (eq? keymap-to-remove ed-keymap)
+            (error 'keymap:remove-keymap "cannot remove initial keymap from editor"))
+          (let p-loop ([parent-keymap ed-keymap])
+            (unless (is-a? parent-keymap aug-keymap<%>)
+              (error 'keymap:remove-keymap
+                     "found a keymap that is not a keymap:aug-keymap<%> ~e" 
+                     parent-keymap))
+            (let c-loop ([child-keymaps (send parent-keymap get-chained-keymaps)])
+              (cond
+                [(null? child-keymaps) null]
+                [else
+                 (let ([child-keymap (car child-keymaps)])
+                   (cond
+                     [(eq? child-keymap keymap-to-remove)
+                      (send parent-keymap remove-chained-keymap child-keymap)
+                      (c-loop (cdr child-keymaps))]
+                     [else 
+                      (p-loop child-keymap)
+                      (c-loop (cdr child-keymaps))]))])))))
       
+      (define (set-chained-keymaps parent-keymap children-keymaps)
+        (for-each (lambda (orig-sub) (send parent-keymap remove-chained-keymap))
+                  (send parent-keymap get-chained-keymaps))
+        (for-each (lambda (new-sub) (send parent-keymap chain-to-keymap new-sub #f))
+                  children-keymaps))
+        
       (define aug-keymap<%> (interface ((class->interface keymap%))
 			      get-chained-keymaps
 			      get-map-function-table
@@ -35,16 +62,20 @@
           [define get-chained-keymaps
             (lambda ()
               chained-keymaps)]
-	  (rename [super-chain-to-keymap chain-to-keymap])
-	  (override chain-to-keymap)
-          [define chain-to-keymap
-	    (lambda (keymap prefix?)
-	      (super-chain-to-keymap keymap prefix?)
-	      (set! chained-keymaps
-		    (if prefix?
-			(cons keymap chained-keymaps)
-			(append chained-keymaps (list keymap)))))]
 	  
+          (rename [super-chain-to-keymap chain-to-keymap])
+	  (define/override (chain-to-keymap keymap prefix?)
+            (super-chain-to-keymap keymap prefix?)
+            (set! chained-keymaps
+                  (if prefix?
+                      (cons keymap chained-keymaps)
+                      (append chained-keymaps (list keymap)))))
+	  
+          (rename [super-remove-chained-keymap remove-chained-keymap])
+          (define/override (remove-chained-keymap keymap)
+            (super-remove-chained-keymap keymap)
+            (set! chained-keymaps (remq keymap chained-keymaps)))
+          
 	  [define function-table (make-hash-table)]
 	  (public get-function-table)
           [define get-function-table (lambda () function-table)]

collects/framework/private/mode.ss

@@ -1,5 +1,5 @@
 (module mode mzscheme
-  (require (lib "delegate.ss")
+  (require (lib "surrogate.ss")
            (lib "unitsig.ss")
            "sig.ss")
   
@@ -9,8 +9,8 @@
     (unit/sig framework:mode^
       (import)
       
-      (define-values (delegating-text-mixin text% text<%>)
-        (delegate
+      (define-values (host-text-mixin surrogate-text% surrogate-text<%>)
+        (surrogate
          (on-change ())
          (on-char (event))
          (on-default-char (event))
@@ -48,6 +48,6 @@
          (can-delete? (start len))
          (can-insert? (start len))
          (can-set-size-constraint? ())
-         (can-do-edit-operation? (op recursive?))
+         (can-do-edit-operation? (op) (op recursive?))
          (can-load-file? (filename format))
          (can-save-file? (filename format)))))))

collects/framework/private/scheme.ss

@@ -317,7 +317,7 @@
           (send style-list find-named-style "Matching Parenthesis Style")))
 
       (define text-mixin
-        (mixin (text:basic<%> editor:keymap<%>) (-text<%>)
+        (mixin (text:basic<%>) (-text<%>)
           (inherit begin-edit-sequence
                    delete
                    end-edit-sequence
@@ -407,12 +407,12 @@
           
           (define/public highlight-parens
             (opt-lambda ([just-clear? #f])
-              (when (preferences:get 'framework:highlight-parens)
-                (unless in-highlight-parens?
-                  (set! in-highlight-parens? #t)
-                  (begin-edit-sequence)
-                  (clear-old-locations)
-                  (set! clear-old-locations void)
+              (unless in-highlight-parens?
+                (set! in-highlight-parens? #t)
+                (begin-edit-sequence)
+                (clear-old-locations)
+                (set! clear-old-locations void)
+                (when (preferences:get 'framework:highlight-parens)
                   (unless just-clear?
                     (let* ([here (get-start-position)]
                            [there (get-end-position)]
@@ -489,9 +489,9 @@
                              (handle-single before)]
                             [after (handle-single after)]
                             [before (handle-single before)]
-                            [else (void)])))))
-                  (end-edit-sequence)
-                  (set! in-highlight-parens? #f)))))
+                            [else (void)]))))))
+                (end-edit-sequence)
+                (set! in-highlight-parens? #f))))
           
           (public get-limit balance-quotes balance-parens tabify-on-return? tabify tabify-selection
                   tabify-all insert-return calc-last-para 
@@ -1074,23 +1074,17 @@
           [define get-tab-size (lambda () tab-size)]
           [define set-tab-size (lambda (s) (set! tab-size s))]
           
-          (rename [super-get-keymaps get-keymaps])
-          (override get-keymaps)
-          [define get-keymaps
-            (lambda ()
-              (cons keymap (super-get-keymaps)))]
-          
           (rename [super-after-delete after-delete])
           (define/override (after-delete start size)
             (send backward-cache invalidate start)
             (send forward-cache forward-invalidate (+ start size) (- size))
-            ;; must call super after invalidating cache -- super calls delegate object
+            ;; must call super after invalidating cache -- super calls surrogate object
             (super-after-delete start size))
           (rename [super-after-insert after-insert])
           (define/override (after-insert start size)
             (send backward-cache invalidate start)
             (send forward-cache forward-invalidate start size)
-            ;; must call super after invalidating cache -- super calls delegate object
+            ;; must call super after invalidating cache -- super calls surrogate object
             (super-after-insert start size))
           
           (super-instantiate ())))
@@ -1100,7 +1094,7 @@
           ))
       
       (define text-mode-mixin
-        (mixin (mode:text<%>) (-text-mode<%>)
+        (mixin (mode:surrogate-text<%>) (-text-mode<%>)
           (rename [super-on-focus on-focus])
           (define/override (on-focus text on?)
             (super-on-focus text on?)
@@ -1117,9 +1111,8 @@
           (rename [super-after-edit-sequence after-edit-sequence])
           (define/override (after-edit-sequence text)
             (super-after-edit-sequence text)
-            (unless (send text local-edit-sequence?)
-              (when (send text has-focus?)
-                (send text highlight-parens))))
+            (when (send text has-focus?)
+              (send text highlight-parens)))
           
           (rename [super-after-insert after-insert])
           (define/override (after-insert text start size)
@@ -1132,7 +1125,8 @@
           (define/override (after-delete text start size)
             (unless (send text local-edit-sequence?)
               (when (send text has-focus?)
-                (send text highlight-parens))))
+                (send text highlight-parens)))
+            (super-after-delete text start size))
           
           (rename [super-after-set-size-constraint after-set-size-constraint])
           (define/override (after-set-size-constraint text)
@@ -1148,15 +1142,22 @@
                 (send text highlight-parens)))
             (super-after-set-position text))
 
-          (rename [super-on-disable-delegate on-disable-delegate])
-          (define/override (on-disable-delegate text)
+          (rename [super-on-disable-surrogate on-disable-surrogate])
+          (define/override (on-disable-surrogate text)
+            (keymap:remove-chained-keymap text keymap)
             (send text highlight-parens #t)
-            (super-on-disable-delegate text))
+            (super-on-disable-surrogate text))
           
-          (rename [super-on-enable-delegate on-enable-delegate])
-          (define/override (on-enable-delegate text)
-            (super-on-enable-delegate text)
-            (send text highlight-parens #t)
+          (rename [super-on-enable-surrogate on-enable-surrogate])
+          (define/override (on-enable-surrogate text)
+            (super-on-enable-surrogate text)
+            (send (send text get-keymap) chain-to-keymap keymap #t)
+            (unless (send text local-edit-sequence?)
+              (when (send text has-focus?)
+                (send text highlight-parens)))
+            
+            ;; I don't know about these editor flag settings.
+            ;; maybe they belong in drscheme?
             (send text set-load-overwrites-styles #f)
             (send text set-wordbreak-map wordbreak-map)
             (send text set-tabs null (send text get-tab-size) #f)
@@ -1165,7 +1166,8 @@
           (super-instantiate ())))
 
       (define -text% (text-mixin text:info%))
-      
+      (define text-mode% (text-mode-mixin mode:surrogate-text%))
+    
                                                                                            
               ;;                                 ;;                                        
                ;                                  ;                                        

collects/framework/private/sig.ss

@@ -463,6 +463,9 @@
      get-file
      get-editor
 
+     set-chained-keymaps
+     remove-chained-keymap
+     
      call/text-keymap-initializer))
   (define-signature framework:keymap^
     ((open framework:keymap-class^)
@@ -494,7 +497,11 @@
     (text<%>
      text-mixin
      text%
+     
+     text-mode<%>
      text-mode-mixin
+     text-mode%
+     
      sexp-snip%
      sexp-snip<%>))
   (define-signature framework:scheme-fun^
@@ -525,9 +532,9 @@
      (open framework:main-fun^)))
 
   (define-signature framework:mode-class^ 
-    (delegating-text-mixin
-     text%
-     text<%>))
+    (host-text-mixin
+     surrogate-text%
+     surrogate-text<%>))
   (define-signature framework:mode-fun^ ())
   (define-signature framework:mode^
     ((open framework:mode-class^)