improve DrScheme's auto-indenting and S-exp movement for Scheme code with quote, #;, etc.

svn: r5977

collects/framework/private/scheme.ss

@@ -303,11 +303,14 @@
   (define (get-white-on-black-color-prefs-table) white-on-black-color-prefs-table)
       
       (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
+      (define (xlate-sym-style sym) (case sym
+                                      [(sexp-comment) 'comment]
+                                      [else sym]))
       (define sn-hash (make-hash-table))
       (define (short-sym->style-name sym)
 	(hash-table-get sn-hash sym
 			(λ ()
-			  (let ([s (format "framework:syntax-coloring:scheme:~a" sym)])
+			  (let ([s (format "framework:syntax-coloring:scheme:~a" (xlate-sym-style sym))])
 			    (hash-table-put! sn-hash sym s)
 			    s))))
       
@@ -462,7 +465,10 @@
 		     ;; "last" is the start of the S-exp just before "pos"
                      [last 
                       (if contains
-                          (backward-match end limit)
+                          (let ([p (get-backward-sexp end)])
+                            (if (and p (p . >= . limit))
+                                p
+                                (backward-match end limit)))
                           #f)]
                      [last-para (and last
                                      (position-paragraph last))])
@@ -783,24 +789,28 @@
                 (delete snip-pos (+ snip-pos 1)))
               (set-position pos pos)))
 
+          (define/private (stick-to-next-sexp? start-pos)
+            (let ([end-pos (forward-match start-pos (last-position))])
+              (and end-pos
+                   (member (get-text start-pos end-pos)
+                           '("'" "," ",@" "`"
+                             "#'" "#," "#`" "#,@"
+                             "#&" "#;"
+                             "#hash" "#hasheq"
+                             "#ci" "#cs")))))
 
           (define/public (get-forward-sexp start-pos) 
-            (forward-match start-pos (last-position))
-            
-            ;; the below is my first attempt to get forward/backward sexp 
-            ;;  to work properly with qutoe.
-            ;; it broke the tabber, so I took it out for now.
-            #;
-            (let ([one-forward (forward-match start-pos (last-position))])
+            ;; loop to work properly with quote, etc.
+            (let loop ([one-forward (forward-match start-pos (last-position))])
               (cond
                 [(and one-forward (not (= 0 one-forward)))
                  (let ([bw (backward-match one-forward 0)])
                    (cond
                      [(and bw 
-                           (= (- one-forward 1) bw)
-                           (member (get-character bw) '(#\, #\` #\')))
+                           (stick-to-next-sexp? bw))
                       (let ([two-forward (forward-match one-forward (last-position))])
-                        (or two-forward
+                        (if two-forward
+                            (loop two-forward)
                             one-forward))]
                      [else
                       one-forward]))]
@@ -832,7 +842,16 @@
               (if (and end-pos 
                        (or (not min-pos)
                            (end-pos . >= . min-pos)))
-                  end-pos
+                  ;; Can go backward, but check for preceding quote, unquote, etc.
+                  (let loop ([end-pos end-pos])
+                    (let ([next-end-pos (backward-match end-pos limit)])
+                      (if (and next-end-pos
+                               (or (not min-pos)
+                                   (end-pos . >= . min-pos))
+                               (stick-to-next-sexp? next-end-pos))
+                          (loop next-end-pos)
+                          end-pos)))
+                  ;; can't go backward at all:
                   #f)))
           [define flash-backward-sexp
             (λ (start-pos)

collects/syntax-color/doc.txt

@@ -21,8 +21,8 @@ scheme-lexer returns 5 values:
    currently return an empty string.  This may change in the future to
    other string or non-string data.
 
- - A symbol in '(error comment white-space constant string no-color
-   parenthesis other symbol eof)
+ - A symbol in '(error comment sexp-comment white-space constant string 
+   no-color parenthesis other symbol eof)
 
  - A symbol in '(|(| |)| |[| |]| |{| |}|) or #f
 

collects/syntax-color/scheme-lexer.ss

@@ -268,8 +268,10 @@
            (make-num digit16 radix16))
       (ret lexeme 'constant #f start-pos end-pos)]
      [str (ret lexeme 'string #f start-pos end-pos)]
-     [(:or "#;" line-comment) 
+     [line-comment
       (ret lexeme 'comment #f start-pos end-pos)]
+     ["#;"
+      (ret lexeme 'sexp-comment #f start-pos end-pos)]
      ["#|" (read-nested-comment 1 start-pos input-port)]
      [(:: (:or "" "#hash" "#hasheq" (:: "#" (:* digit10))) "(")
       (ret lexeme 'parenthesis '|(| start-pos end-pos)]

collects/tests/syntax-color/scheme-lexer.ss

@@ -14,6 +14,7 @@
     ((symbol) #\i)
     ((constant) #\c)
     ((comment) #\;)
+    ((sexp-comment) #\;)
     ((string) #\s)
     ((parenthesis) #\p)
     ((other) #\o)
@@ -515,7 +516,7 @@ end-string
 (test "#:\\ ,#:a" "ccccoccc")
 (test "#:| |a,#:a" "ccccccoccc")
 (test "#:a#||#" "ccccccc")
-(test "#:a#;1 2" "cccc;;;;")
+; (test "#:a#;1 2" "cccc;;;;")
 (test "#:a#<<a" "ccccccc")
 (test "#:1#!1" "cccccc")
 (test "#:1+nan.0" "ccccccccc")