From 450d9b604e05f36ecfe19615a340aa2071282fa0 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 7 Aug 2009 14:59:14 +0000
Subject: [PATCH] DrScheme: only correct a paren if the inserted character
 would be colored as a parenthesis (which matters for @-form coloring)

svn: r15685
---
 collects/framework/private/color.ss        | 39 +++++++++++++++-------
 collects/scribblings/framework/color.scrbl | 12 ++++---
 2 files changed, 34 insertions(+), 17 deletions(-)

diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss
index 78ae79b813..0151568fa0 100644
--- a/collects/framework/private/color.ss
+++ b/collects/framework/private/color.ss
@@ -849,7 +849,7 @@ added get-regions
                                    comments?))
                  (else position))))))))
     
-    (define/private (get-close-paren pos closers)
+    (define/private (get-close-paren pos closers continue-after-non-paren?)
       (cond
        ((null? closers) #f)
        (else
@@ -859,16 +859,23 @@ added get-regions
             (if ls
                 (let ([start-pos (lexer-state-start-pos ls)])
                   (insert c pos)
-                  (let ((m (backward-match (+ l pos) start-pos)))
-                    (cond
-                     ((and m
-                           (send (lexer-state-parens ls) is-open-pos? (- m start-pos))
-                           (send (lexer-state-parens ls) is-close-pos? (- pos start-pos)))
-                      (delete pos (+ l pos))
-                      c)
-                     (else
-                      (delete pos (+ l pos))
-                      (get-close-paren pos (cdr closers))))))
+                  (let ((cls (classify-position pos)))
+                    (if (eq? cls 'parenthesis)
+                        (let ((m (backward-match (+ l pos) start-pos)))
+                          (cond
+                           ((and m
+                                 (send (lexer-state-parens ls) is-open-pos? (- m start-pos))
+                                 (send (lexer-state-parens ls) is-close-pos? (- pos start-pos)))
+                            (delete pos (+ l pos))
+                            c)
+                           (else
+                            (delete pos (+ l pos))
+                            (get-close-paren pos (cdr closers) #t))))
+                        (begin
+                          (delete pos (+ l pos))
+                          (if continue-after-non-paren?
+                              (get-close-paren pos (cdr closers) #t)
+                              #f)))))
                 c))))))
     
     (inherit insert delete flash-on on-default-char)
@@ -877,7 +884,15 @@ added get-regions
       (let ((closer
              (begin
                (begin-edit-sequence #f #f)
-               (get-close-paren pos (if fixup? (map symbol->string (map cadr pairs)) null)))))
+               (get-close-paren pos 
+                                (if fixup? 
+                                    (let ([l (map symbol->string (map cadr pairs))])
+                                      ;; Ensure preference for given character:
+                                      (cons (string char) (remove (string char) l)))
+                                    null)
+                                ;; If the inserted preferred (i.e., given) paren doesn't parse
+                                ;;  as a paren, then don't try to change it.
+                                #f))))
         (end-edit-sequence)
         (let ((insert-str (if closer closer (string char))))
           (for-each (lambda (c)
diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl
index 9f33186ab7..258932d3a8 100644
--- a/collects/scribblings/framework/color.scrbl
+++ b/collects/scribblings/framework/color.scrbl
@@ -203,11 +203,13 @@
   }
   @defmethod*[(((insert-close-paren (position natural-number?) (char char?) (flash? boolean?) (fixup? boolean?)) void))]{
 
-    Position is the place to put the parenthesis and char is the
-    parenthesis to be added.  If @scheme[fixup?] is true, the right kind of closing
-    parenthesis will be chosen from the pairs list kept last passed to
-    @scheme[start-colorer], otherwise char will be inserted, even if it is not the
-    right kind.  If @scheme[flash?] is true the matching open parenthesis will be
+    The @scheme[position] is the place to put the parenthesis, and @scheme[char] is the
+    parenthesis to be added (e.g., that the user typed).  If @scheme[fixup?] is true, the right kind of closing
+    parenthesis will be chosen from the set previously passed to
+    @scheme[start-colorer]---but only if an inserted @scheme[char] would be colored
+    as a parenthesis (i.e., with the @scheme['parenthesis] classification).
+    Otherwise, @scheme[char] will be inserted, even if it is not the
+    right kind.  If @scheme[flash?] is true, the matching open parenthesis will be
     flashed.
   }
   @defmethod*[(((classify-position (position natural-number?)) symbol?))]{