suzanne.soy/racket
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
This commit is contained in:
Robby Findler 2006-04-12 21:38:44 +00:00
parent 4ee3f7e7b1
commit a6244d0896
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?)
(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

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

@ -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"