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

fix c:c;c:e for empty sequences

Browse Source 
closes PR 13905

original commit: c107ad1f7743ea4766e8f281fae8d8b3f39fedbd
This commit is contained in:
Robby Findler 2013-07-06 10:33:19 -05:00
parent 339f30b9cb
commit 6546d4c781
3 changed files with 33 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
pkgs/drracket-pkgs/drracket-test/tests/drracket/private/gui.rkt
View File

@ -1,125 +0,0 @@
#lang racket/base
(require racket/gui/base
racket/class)
(provide find-labelled-window
find-labelled-windows
whitespace-string=?)
;; whitespace-string=? : string string -> boolean
;; determines if two strings are equal, up to their whitespace.
;; each string is required to have whitespace in the same place,
;; but not necessarily the same kinds or amount.
(define (whitespace-string=? string1 string2)
(let loop ([i 0]
[j 0]
[in-whitespace? #t])
(cond
[(= i (string-length string1)) (only-whitespace? string2 j)]
[(= j (string-length string2)) (only-whitespace? string1 i)]
[else (let ([c1 (string-ref string1 i)]
[c2 (string-ref string2 j)])
(cond
[in-whitespace?
(cond
[(whitespace? c1)
(loop (+ i 1)
j
#t)]
[(whitespace? c2)
(loop i
(+ j 1)
#t)]
[else (loop i j #f)])]
[(and (whitespace? c1)
(whitespace? c2))
(loop (+ i 1)
(+ j 1)
#t)]
[(char=? c1 c2)
(loop (+ i 1)
(+ j 1)
#f)]
[else #f]))])))
;; whitespace? : char -> boolean
;; deteremines if `c' is whitespace
(define (whitespace? c)
(or (char=? c #\newline)
(char=? c #\space)
(char=? c #\tab)
(char=? c #\return)))
;; only-whitespace? : string number -> boolean
;; returns true if string only contains whitespace, from index `i' onwards
(define (only-whitespace? str i)
(let loop ([n i])
(cond
[(= n (string-length str))
#t]
[(whitespace? (string-ref str n))
(loop (+ n 1))]
[else #f])))
;; whitespace-string=? tests
(module+ test
(require rackunit)
(check-equal? #t (whitespace-string=? "a" "a"))
(check-equal? #f (whitespace-string=? "a" "A"))
(check-equal? #f (whitespace-string=? "a" " "))
(check-equal? #f (whitespace-string=? " " "A"))
(check-equal? #t (whitespace-string=? " " " "))
(check-equal? #t (whitespace-string=? " " " "))
(check-equal? #t (whitespace-string=? " " " "))
(check-equal? #t (whitespace-string=? " " " "))
(check-equal? #t (whitespace-string=? "a a" "a a"))
(check-equal? #t (whitespace-string=? "a a" "a a"))
(check-equal? #t (whitespace-string=? "a a" "a a"))
(check-equal? #t (whitespace-string=? " a" "a"))
(check-equal? #t (whitespace-string=? "a" " a"))
(check-equal? #t (whitespace-string=? "a " "a"))
(check-equal? #t (whitespace-string=? "a" "a ")))
;;; find-labelled-window : (union ((union #f string) -> window<%>)
;;; ((union #f string) (union #f class) -> window<%>)
;;; ((union #f string) (union class #f) area-container<%> -> window<%>))
;;;; may call error, if no control with the label is found
(define (find-labelled-window label
[class #f]
[window (get-top-level-focus-window)]
[failure (λ ()
(error 'find-labelled-window "no window labelled ~e in ~e~a"
label
window
(if class
(format " matching class ~e" class)
"")))])
(define windows (find-labelled-windows label class window))
(cond
[(null? windows) (failure)]
[else (car windows)]))
(define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)])
(unless (or (not label)
(string? label))
(error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e"
label class window))
(unless (or (class? class)
(not class))
(error 'find-labelled-windows "second argument must be a class or #f, got ~e; other args: ~e ~e"
class label window))
(unless (is-a? window area-container<%>)
(error 'find-labelled-windows "third argument must be a area-container<%>, got ~e; other args: ~e ~e"
window label class))
(let loop ([window window])
(cond
[(and (or (not class)
(is-a? window class))
(let ([win-label (and (is-a? window window<%>)
(send window get-label))])
(equal? label win-label)))
(list window)]
[(is-a? window area-container<%>) (apply append (map loop (send window get-children)))]
[else '()])))

13
pkgs/gui-pkgs/gui-lib/framework/private/racket.rkt
View File

@ -546,6 +546,7 @@
#f)] #f)]
[last-para (and last [last-para (and last
(position-paragraph last))]) (position-paragraph last))])
(define sizing-dc (or (get-dc) (make-object bitmap-dc% (make-bitmap 1 1))))
(letrec (letrec
([find-offset ([find-offset
(λ (start-pos) (λ (start-pos)
@ -568,7 +569,7 @@
(position-location start-pos start-x #f #t #t) (position-location start-pos start-x #f #t #t)
(position-location end-pos end-x #f #t #t) (position-location end-pos end-x #f #t #t)
(define-values (w _1 _2 _3) (define-values (w _1 _2 _3)
(send (get-dc) get-text-extent "x" (send sizing-dc get-text-extent "x"
(send (send (get-style-list) (send (send (get-style-list)
find-named-style "Standard") find-named-style "Standard")
get-font))) get-font)))
@ -1141,17 +1142,17 @@
(define/public (kill-enclosing-parens begin-inner) (define/public (kill-enclosing-parens begin-inner)
(begin-edit-sequence) (begin-edit-sequence)
(let ([begin-outer (find-up-sexp begin-inner)]) (define begin-outer (find-up-sexp begin-inner))
(cond (cond
[begin-outer [begin-outer
(let ([end-outer (get-forward-sexp begin-outer)]) (define end-outer (get-forward-sexp begin-outer))
(cond (cond
[(and end-outer (> (- end-outer begin-outer) 2)) [(and end-outer (>= (- end-outer begin-outer) 2))
(delete (- end-outer 1) end-outer) (delete (- end-outer 1) end-outer)
(delete begin-outer (+ begin-outer 1)) (delete begin-outer (+ begin-outer 1))
(tabify-selection begin-outer (- end-outer 2))] (tabify-selection begin-outer (- end-outer 2))]
[else (bell)]))] [else (bell)])]
[else (bell)])) [else (bell)])
(end-edit-sequence)) (end-edit-sequence))
;; change the parens following the cursor from () to [] or vice versa ;; change the parens following the cursor from () to [] or vice versa

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

@ -94,14 +94,15 @@
(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-insert-close-paren/proc line (define (test-message-send/proc line before after pos msg . args)
pos char flash? fixup? smart-skip (define (maybe-quote x)
before after) (cond
[(or (number? x) (boolean? x) (string? x)) x]
[else `',x]))
(test (test
(string->symbol (format "line ~a: ~s" (string->symbol (format "line ~a: ~s"
line line
`(test-insert-close-paren ,pos ,char ,flash? ,fixup? ',smart-skip `(,msg ,@(map maybe-quote args))))
,before ,after)))
(λ (x) (equal? x after)) (λ (x) (equal? x after))
(λ () (λ ()
(queue-sexp-to-mred (queue-sexp-to-mred
@ -111,19 +112,24 @@
(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 insert-close-paren ,pos ,char ,flash? ,fixup? ',smart-skip) (send t ,msg ,@(map maybe-quote args))
(send t get-text)))))) (send t get-text))))))
(define-syntax (test-insert-close-paren stx) (define-syntax (test-message-send stx)
(syntax-case stx () (syntax-case stx ()
[(_ . args) [(_ before after pos mth . args)
(with-syntax ([line (syntax-line stx)]) (with-syntax ([line (syntax-line stx)])
#'(test-insert-close-paren/proc line . args))])) #'(test-message-send/proc line before after pos 'mth . args))]))
(test-insert-close-paren 0 #\] #t #t 'adjacent "" "]") (test-message-send "" "]" 0 insert-close-paren 0 #\] #t #t 'adjacent)
(test-insert-close-paren 0 #\] #t #t #f "" "]") (test-message-send "" "]" 0 insert-close-paren 0 #\] #t #t #f)
(test-insert-close-paren 1 #\] #t #t #f "(" "()") (test-message-send "(" "()" 1 insert-close-paren 1 #\] #t #t #f)
(test-insert-close-paren 1 #\] #f #f #f "(" "(]") (test-message-send "(" "(]" 1 insert-close-paren 1 #\] #f #f #f)
(test-insert-close-paren 0 #\] #t #t 'forward "" "]") (test-message-send "" "]" 0 insert-close-paren 0 #\] #t #t 'forward)
(test-message-send "(1)" "1" 1 kill-enclosing-parens 1)
(test-message-send "(1 2 3)" "1 2 3" 3 kill-enclosing-parens 3)
(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
;; 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