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

adjust backward-containing-sexp so that it returns #f

Browse Source 
when there is no containing paren

it used to return the beginning of the region (usually 0)

(this adjusts backward-containing-sexp to agree with the docs)

original commit: e1f4547ea99200c6ad0e9c34a76d3eb19eb906b6
This commit is contained in:
Robby Findler 2013-07-22 11:41:14 -05:00
parent 7c3b161e3f
commit 716a40773f
2 changed files with 17 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/gui-pkgs/gui-lib/framework/private/color.rkt
View File

@ -825,7 +825,7 @@ added get-regions
(define/public (backward-match position cutoff) (define/public (backward-match position cutoff)
(let ((x (internal-backward-match position cutoff))) (let ((x (internal-backward-match position cutoff)))
(cond (cond
((eq? x 'open) #f) ((or (eq? x 'open) (eq? x 'beginning)) #f)
(else x)))) (else x))))
(define/private (internal-backward-match position cutoff) (define/private (internal-backward-match position cutoff)
@ -855,9 +855,10 @@ added get-regions
(values (send (lexer-state-tokens ls) get-root-start-position) (values (send (lexer-state-tokens ls) get-root-start-position)
(send (lexer-state-tokens ls) get-root-end-position))))) (send (lexer-state-tokens ls) get-root-end-position)))))
(cond (cond
((or (send (lexer-state-parens ls) is-open-pos? tok-start) ((send (lexer-state-parens ls) is-open-pos? tok-start)
(= (+ start-pos tok-start) position))
'open) 'open)
((= (+ start-pos tok-start) position)
'beginning)
(else (else
(+ start-pos tok-start)))))))))) (+ start-pos tok-start))))))))))
@ -874,6 +875,7 @@ added get-regions
;; the docs seem to indicate it ;; the docs seem to indicate it
;; does, but it doesn't really ;; does, but it doesn't really
cur-pos) cur-pos)
((eq? 'beginning p) #f)
((not p) #f) ((not p) #f)
(else (loop p)))))) (else (loop p))))))

18
pkgs/gui-pkgs/gui-test/framework/tests/racket.rkt
View File

@ -94,7 +94,9 @@
(test-magic-square-bracket 'local2 "(local [(define x 1)] " "(local [(define x 1)] (") (test-magic-square-bracket 'local2 "(local [(define x 1)] " "(local [(define x 1)] (")
(define (test-message-send/proc line before after pos msg . args) (define (test-message-send/proc line before expected pos msg
#:check-result? [check-result? #f]
. args)
(define (maybe-quote x) (define (maybe-quote x)
(cond (cond
[(or (number? x) (boolean? x) (string? x)) x] [(or (number? x) (boolean? x) (string? x)) x]
@ -103,7 +105,7 @@
(string->symbol (format "line ~a: ~s" (string->symbol (format "line ~a: ~s"
line line
`(,msg ,@(map maybe-quote args)))) `(,msg ,@(map maybe-quote args))))
(λ (x) (equal? x after)) (λ (x) (equal? x expected))
(λ () (λ ()
(queue-sexp-to-mred (queue-sexp-to-mred
`(let () `(let ()
@ -112,13 +114,15 @@
(define ec (new editor-canvas% [parent f] [editor t])) (define ec (new editor-canvas% [parent f] [editor t]))
(send t insert ,before) (send t insert ,before)
(send t set-position ,pos) (send t set-position ,pos)
(send t ,msg ,@(map maybe-quote args)) (define ans (send t ,msg ,@(map maybe-quote args)))
(send t get-text)))))) ,(if check-result?
'ans
'(send t get-text)))))))
(define-syntax (test-message-send stx) (define-syntax (test-message-send stx)
(syntax-case stx () (syntax-case stx ()
[(_ before after pos mth . args) [(_ before expected pos mth . args)
(with-syntax ([line (syntax-line stx)]) (with-syntax ([line (syntax-line stx)])
#'(test-message-send/proc line before after pos 'mth . args))])) #'(test-message-send/proc line before expected pos 'mth . args))]))
(test-message-send "" "]" 0 insert-close-paren 0 #\] #t #t 'adjacent) (test-message-send "" "]" 0 insert-close-paren 0 #\] #t #t 'adjacent)
(test-message-send "" "]" 0 insert-close-paren 0 #\] #t #t #f) (test-message-send "" "]" 0 insert-close-paren 0 #\] #t #t #f)
@ -131,6 +135,8 @@
(test-message-send "()" "" 1 kill-enclosing-parens 1) (test-message-send "()" "" 1 kill-enclosing-parens 1)
(test-message-send "(1\n 2\n 3)" "1\n2\n3" 1 kill-enclosing-parens 1) ;; test tabify call (test-message-send "(1\n 2\n 3)" "1\n2\n3" 1 kill-enclosing-parens 1) ;; test tabify call
(test-message-send "abc" #f 1 backward-containing-sexp #:check-result? #t 1 3)
;; tests what happens when a given key/s is/are typed in an editor with initial ;; tests what happens when a given key/s is/are typed in an editor with initial
;; text and cursor position, under different settings of the auto-parentheses and ;; text and cursor position, under different settings of the auto-parentheses and
;; smart-skip-parentheses preferences .nah. ;; smart-skip-parentheses preferences .nah.