From 40eb0859c36682a1a0f22bb61ca4254c5e114346 Mon Sep 17 00:00:00 2001
From: Scott Owens <sowens@cs.utah.edu>
Date: Sun, 14 Dec 2003 22:02:03 +0000
Subject: [PATCH] *** empty log message ***

original commit: bfc30a6a6e4df253723a4e44836427da6897ea4e
---
 collects/framework/private/color.ss  | 32 ++++++++++++++++++-
 collects/framework/private/scheme.ss | 47 +++-------------------------
 2 files changed, 35 insertions(+), 44 deletions(-)

diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss
index 1ad601f6..81bf2202 100644
--- a/collects/framework/private/color.ss
+++ b/collects/framework/private/color.ss
@@ -42,7 +42,7 @@
           backward-containing-sexp
           forward-match
           balanced?
-          in-single-line-comment?))
+          insert-close-paren))
 
       (define text-mixin
         (mixin (text:basic<%>) (-text<%>)
@@ -645,6 +645,36 @@
             (eq? 'comment (send tokens get-root-data)))
           
           
+          (define (get-close-paren pos closers)
+            (cond
+              ((null? closers) #f)
+              (else
+               (let* ((c (car closers))
+                      (l (string-length c)))
+                 (insert c)
+                 (let ((m (backward-match (+ l pos) start-pos)))
+                   (cond
+                     ((and m (send parens is-open-pos? m))
+                      (delete pos (+ l pos))
+                      c)
+                     (else
+                      (delete pos (+ l pos))                      
+                      (get-close-paren pos (cdr closers)))))))))
+          
+          (inherit insert delete flash-on)
+          (define/public (insert-close-paren pos char flash? fixup?)
+            (let ((closer
+                   (begin
+                     (begin-edit-sequence #f #f)
+                     (get-close-paren pos (if fixup? (map symbol->string (map cadr pairs)) null)))))
+              (end-edit-sequence)
+              (let ((insert-str (if closer closer (string char))))
+                (insert insert-str)
+                (when flash?
+                  (let ((pos (backward-match (+ (string-length insert-str) pos) 0)))
+                    (when (and pos (send parens is-open-pos? pos))
+                      (flash-on pos (+ 1 pos))))))))
+          
           ;; ------------------------- Callbacks to Override ----------------------
           
           (rename (super-lock lock))
diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss
index 00b36fe5..d6de26b3 100644
--- a/collects/framework/private/scheme.ss
+++ b/collects/framework/private/scheme.ss
@@ -382,7 +382,7 @@
                    backward-containing-sexp
                    forward-match
                    skip-whitespace
-                   in-single-line-comment?)
+                   insert-close-paren)
           
           
           (inherit get-styles-fixed)
@@ -421,49 +421,10 @@
                   remove-parens-forward)
           (define (get-limit pos) 0)
           
-        
           (define (balance-parens key-event)
-            (letrec ([char (send key-event get-key-code)] ;; must be a character. See above.
-                     [here (get-start-position)]
-                     [limit (get-limit here)]
-                     [paren-match? (preferences:get 'framework:paren-match)]
-                     [fixup-parens? (preferences:get 'framework:fixup-parens)]
-                     [find-match
-                      (lambda (pos)
-                        (let loop ([parens (scheme-paren:get-paren-pairs)])
-                          (cond
-                            [(null? parens) #f]
-                            [else (let* ([paren (car parens)]
-                                         [left (car paren)]
-                                         [right (cdr paren)])
-                                    (if (string=? left (get-text pos (+ pos (string-length left))))
-                                        right
-                                        (loop (cdr parens))))])))])
-              (cond
-                [(in-single-line-comment? here)
-                 (insert char)]
-                [(and (not (= 0 here))
-                      (char=? (string-ref (get-text (- here 1) here) 0) #\\))
-                 (insert char)]
-                [(or paren-match? fixup-parens?)
-                 (let* ([end-pos (backward-containing-sexp here limit)])
-                   (cond
-                     [end-pos
-                      (let* ([left-paren-pos (find-enclosing-paren end-pos)]
-                             [match (and left-paren-pos
-                                         (find-match left-paren-pos))])
-                        (cond
-                          [match
-                              (insert (if fixup-parens? match char))
-                            (when paren-match?
-                              (flash-on
-                               left-paren-pos
-                               (+ left-paren-pos (string-length match))))]
-                          [else
-                           (insert char)]))]
-                     [else (insert char)]))]
-                [else (insert char)])
-              #t))
+            (insert-close-paren (get-start-position) (send key-event get-key-code)
+                                (preferences:get 'framework:paren-match)
+                                (preferences:get 'framework:fixup-parens)))
           
           (define (tabify-on-return?) #t)
           (define tabify