suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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)

Browse Source 
svn: r2667

original commit: a6244d0896e4b9f626a2c63c29825af6951fb905
This commit is contained in:
Robby Findler 2006-04-12 21:38:44 +00:00
parent 9d6e8836df
commit 064180d763
2 changed files with 48 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
collects/framework/private/scheme.ss
View File

@ -974,14 +974,15 @@
(inherit is-frozen? is-stopped?) (inherit is-frozen? is-stopped?)
(define/public (rewrite-square-paren) (define/public (rewrite-square-paren)
(insert (cond (cond
[(or (not (preferences:get 'framework:fixup-parens)) [(or (not (preferences:get 'framework:fixup-parens))
(is-frozen?) (is-frozen?)
(is-stopped?)) (is-stopped?))
#\[] (insert #\[
[else (choose-paren this (get-start-position))]) (get-start-position)
(get-start-position) (get-end-position))]
(get-end-position))) [else
(insert-paren this)]))
(super-new))) (super-new)))
@ -1226,9 +1227,14 @@
;; choose-paren : scheme-text number -> character ;; choose-paren : scheme-text number -> character
;; returns the character to replace a #\[ with, based ;; returns the character to replace a #\[ with, based
;; on the context where it is typed in. ;; on the context where it is typed in.
(define (choose-paren text pos) (define (insert-paren text)
(if (memq (send text classify-position pos) '(string error comment symbol constant)) (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)] (let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)]
[backward-match (send text backward-match before-whitespace-pos 0)]) [backward-match (send text backward-match before-whitespace-pos 0)])
(let ([b-m-char (and (number? backward-match) (send text get-character backward-match))]) (let ([b-m-char (and (number? backward-match) (send text get-character backward-match))])
@ -1246,20 +1252,19 @@
text text
backward-match2 backward-match2
before-whitespace-pos2)) before-whitespace-pos2))
#\[] (void)]
[(member b-m-char '(#\( #\[ #\{)) [(member b-m-char '(#\( #\[ #\{))
;; found a "sibling" parenthesized sequence. use the parens it uses. ;; found a "sibling" parenthesized sequence. use the parens it uses.
b-m-char] (change-to b-m-char)]
[else [else
;; there is a sexp before this, but it isn't parenthesized. ;; 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 it is the `cond' keyword, we get a square bracket. otherwise not.
(if (and (beginning-of-sequence? text backward-match) (unless (and (beginning-of-sequence? text backward-match)
(ormap (ormap
(λ (x) (λ (x)
(text-between-equal? x text backward-match before-whitespace-pos)) (text-between-equal? x text backward-match before-whitespace-pos))
'("cond" "provide/contract"))) '("cond" "provide/contract")))
#\[ (change-to #\())]))]
#\()]))]
[(not (zero? before-whitespace-pos)) [(not (zero? before-whitespace-pos))
;; this is the first thing in the sequence ;; this is the first thing in the sequence
;; pop out one layer and look for a keyword. ;; 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))]) (let ([b-w-p-char (send text get-character (- before-whitespace-pos 1))])
(cond (cond
[(equal? b-w-p-char #\() [(equal? b-w-p-char #\()
(let* ([second-before-whitespace-pos (send text skip-whitespace (- before-whitespace-pos 1) 'backward #t)] (let* ([second-before-whitespace-pos (send text skip-whitespace
[second-backwards-match (send text backward-match second-before-whitespace-pos 0)]) (- before-whitespace-pos 1)
'backward
#t)]
[second-backwards-match (send text backward-match
second-before-whitespace-pos
0)])
(cond (cond
[(not second-backwards-match) [(not second-backwards-match)
#\(] (change-to #\()]
[(and (beginning-of-sequence? text second-backwards-match) [(and (beginning-of-sequence? text second-backwards-match)
(ormap (λ (x) (text-between-equal? x (ormap (λ (x) (text-between-equal? x
text text
@ -1282,12 +1292,14 @@
"let*" "let-values" "let-syntax" "let-struct" "let-syntaxes" "let*" "let-values" "let-syntax" "let-struct" "let-syntaxes"
"letrec" "letrec"
"letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"))) "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values")))
#\[] (void)]
[else [else
#\(]))] (change-to #\()]))]
[else [else
#\(]))] (change-to #\()]))]
[else #\(]))))) [else
(change-to #\()]))))
(send text end-edit-sequence)))
;; beginning-of-sequence? : text number -> boolean ;; beginning-of-sequence? : text number -> boolean
;; determines if this position is at the beginning of a sequence ;; determines if this position is at the beginning of a sequence

23
collects/tests/framework/keys.ss
View File

@ -99,9 +99,9 @@
(substring str pos (string-length str))) (substring str pos (string-length str)))
(+ pos 1) (+ pos 1)
(+ pos 1)) (+ pos 1))
(list (list char)) (list (list #\[))
(list (list char)) (list (list #\[))
(list (list char)))) (list (list #\[))))
(define scheme-specs (define scheme-specs
(list (list
@ -130,13 +130,14 @@
(build-open-bracket-spec "\"" 1 #\[) (build-open-bracket-spec "\"" 1 #\[)
(build-open-bracket-spec "\"\"" 1 #\[) (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 "" 0 #\()
(build-open-bracket-spec "(let (" 6 #\[) (build-open-bracket-spec "(let (" 6 #\[)
(build-open-bracket-spec "(new x% " 8 #\[) (build-open-bracket-spec "(new x% " 8 #\[)
(build-open-bracket-spec "#\\" 1 #\[) (build-open-bracket-spec "#\\" 2 #\[)
(build-open-bracket-spec "#\\a" 1 #\[) (build-open-bracket-spec "#\\a" 2 #\[)
(build-open-bracket-spec "(let ([let (" 12 #\())) (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)) (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)] [after (key-spec-after key-spec)]
[process-key [process-key
(lambda (key) (lambda (key)
(printf "process-key.1 ~s\n" key)
(let ([text-expect (buff-spec-string after)] (let ([text-expect (buff-spec-string after)]
[start-expect (buff-spec-start after)] [start-expect (buff-spec-start after)]
[end-expect (buff-spec-end after)]) [end-expect (buff-spec-end after)])
@ -169,15 +169,10 @@
(for-each process-key keys))) (for-each process-key keys)))
(define (test-specs frame-name frame-class specs) (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)) (send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
(printf "test-specs.2\n")
(wait-for-frame frame-name) (wait-for-frame frame-name)
(printf "test-specs.3\n")
(for-each test-key specs) (for-each test-key specs)
(printf "test-specs.4\n") (send-sexp-to-mred `(send (get-top-level-focus-window) close)))
(send-sexp-to-mred `(send (get-top-level-focus-window) close))
(printf "test-specs.5\n"))
(test-specs "global keybingings test" 'frame:text% global-specs) (test-specs "global keybingings test" 'frame:text% global-specs)
(test-specs "scheme mode keybindings test" (test-specs "scheme mode keybindings test"