From a6244d0896e4b9f626a2c63c29825af6951fb905 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 12 Apr 2006 21:38:44 +0000 Subject: [PATCH] fixed strategy for determining if a paren is really going to be parsed as a paren (as opposed to being in the middle of a string or whatever) svn: r2667 --- collects/framework/private/scheme.ss | 66 ++++++++++++++++------------ collects/tests/framework/keys.ss | 23 ++++------ 2 files changed, 48 insertions(+), 41 deletions(-) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 2710b3a0b8..03fd2eebdf 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -974,14 +974,15 @@ (inherit is-frozen? is-stopped?) (define/public (rewrite-square-paren) - (insert (cond - [(or (not (preferences:get 'framework:fixup-parens)) - (is-frozen?) - (is-stopped?)) - #\[] - [else (choose-paren this (get-start-position))]) - (get-start-position) - (get-end-position))) + (cond + [(or (not (preferences:get 'framework:fixup-parens)) + (is-frozen?) + (is-stopped?)) + (insert #\[ + (get-start-position) + (get-end-position))] + [else + (insert-paren this)])) (super-new))) @@ -1226,9 +1227,14 @@ ;; choose-paren : scheme-text number -> character ;; returns the character to replace a #\[ with, based ;; on the context where it is typed in. - (define (choose-paren text pos) - (if (memq (send text classify-position pos) '(string error comment symbol constant)) - #\[ + (define (insert-paren text) + (let* ([pos (send text get-start-position)] + [change-to + (λ (c) + (send text insert c pos (+ pos 1)))]) + (send text begin-edit-sequence) + (send text insert #\[ pos (send text get-end-position)) + (when (eq? (send text classify-position pos) 'parenthesis) (let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)] [backward-match (send text backward-match before-whitespace-pos 0)]) (let ([b-m-char (and (number? backward-match) (send text get-character backward-match))]) @@ -1246,20 +1252,19 @@ text backward-match2 before-whitespace-pos2)) - #\[] + (void)] [(member b-m-char '(#\( #\[ #\{)) ;; found a "sibling" parenthesized sequence. use the parens it uses. - b-m-char] + (change-to b-m-char)] [else ;; there is a sexp before this, but it isn't parenthesized. ;; if it is the `cond' keyword, we get a square bracket. otherwise not. - (if (and (beginning-of-sequence? text backward-match) - (ormap - (λ (x) - (text-between-equal? x text backward-match before-whitespace-pos)) - '("cond" "provide/contract"))) - #\[ - #\()]))] + (unless (and (beginning-of-sequence? text backward-match) + (ormap + (λ (x) + (text-between-equal? x text backward-match before-whitespace-pos)) + '("cond" "provide/contract"))) + (change-to #\())]))] [(not (zero? before-whitespace-pos)) ;; this is the first thing in the sequence ;; pop out one layer and look for a keyword. @@ -1268,11 +1273,16 @@ (let ([b-w-p-char (send text get-character (- before-whitespace-pos 1))]) (cond [(equal? b-w-p-char #\() - (let* ([second-before-whitespace-pos (send text skip-whitespace (- before-whitespace-pos 1) 'backward #t)] - [second-backwards-match (send text backward-match second-before-whitespace-pos 0)]) + (let* ([second-before-whitespace-pos (send text skip-whitespace + (- before-whitespace-pos 1) + 'backward + #t)] + [second-backwards-match (send text backward-match + second-before-whitespace-pos + 0)]) (cond [(not second-backwards-match) - #\(] + (change-to #\()] [(and (beginning-of-sequence? text second-backwards-match) (ormap (λ (x) (text-between-equal? x text @@ -1282,12 +1292,14 @@ "let*" "let-values" "let-syntax" "let-struct" "let-syntaxes" "letrec" "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"))) - #\[] + (void)] [else - #\(]))] + (change-to #\()]))] [else - #\(]))] - [else #\(]))))) + (change-to #\()]))] + [else + (change-to #\()])))) + (send text end-edit-sequence))) ;; beginning-of-sequence? : text number -> boolean ;; determines if this position is at the beginning of a sequence diff --git a/collects/tests/framework/keys.ss b/collects/tests/framework/keys.ss index 1e36c5cba6..af947bb365 100644 --- a/collects/tests/framework/keys.ss +++ b/collects/tests/framework/keys.ss @@ -99,9 +99,9 @@ (substring str pos (string-length str))) (+ pos 1) (+ pos 1)) - (list (list char)) - (list (list char)) - (list (list char)))) + (list (list #\[)) + (list (list #\[)) + (list (list #\[)))) (define scheme-specs (list @@ -130,13 +130,14 @@ (build-open-bracket-spec "\"" 1 #\[) (build-open-bracket-spec "\"\"" 1 #\[) (build-open-bracket-spec "||" 1 #\[) - (build-open-bracket-spec "ab" 1 #\[) (build-open-bracket-spec "" 0 #\() (build-open-bracket-spec "(let (" 6 #\[) (build-open-bracket-spec "(new x% " 8 #\[) - (build-open-bracket-spec "#\\" 1 #\[) - (build-open-bracket-spec "#\\a" 1 #\[) - (build-open-bracket-spec "(let ([let (" 12 #\())) + (build-open-bracket-spec "#\\" 2 #\[) + (build-open-bracket-spec "#\\a" 2 #\[) + (build-open-bracket-spec "(let ([let (" 12 #\() + (build-open-bracket-spec "ab" 1 #\() + (build-open-bracket-spec "|ab|" 2 #\[))) (send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t)) @@ -152,7 +153,6 @@ [after (key-spec-after key-spec)] [process-key (lambda (key) - (printf "process-key.1 ~s\n" key) (let ([text-expect (buff-spec-string after)] [start-expect (buff-spec-start after)] [end-expect (buff-spec-end after)]) @@ -169,15 +169,10 @@ (for-each process-key keys))) (define (test-specs frame-name frame-class specs) - (printf "test-specs.1\n") (send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t)) - (printf "test-specs.2\n") (wait-for-frame frame-name) - (printf "test-specs.3\n") (for-each test-key specs) - (printf "test-specs.4\n") - (send-sexp-to-mred `(send (get-top-level-focus-window) close)) - (printf "test-specs.5\n")) + (send-sexp-to-mred `(send (get-top-level-focus-window) close))) (test-specs "global keybingings test" 'frame:text% global-specs) (test-specs "scheme mode keybindings test"