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

fixed PR 9770

Browse Source 
svn: r11999
This commit is contained in:
Robby Findler 2008-10-13 00:53:23 +00:00
parent 198b05897b
commit 4c010b7d4a
2 changed files with 164 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/framework/private/text.ss
View File

@ -131,7 +131,9 @@ WARNING: printf is rebound in the body of the unit to always
(define/public-final (get-highlighted-ranges) (define/public-final (get-highlighted-ranges)
(unless ranges-list (unless ranges-list
(set! ranges-list (set! ranges-list
(map car (sort (hash-map ranges cons) (λ (x y) (> (cdr x) (cdr y)))))) (map car (sort (apply append (hash-map ranges (λ (k vs) (map (λ (v) (cons k v)) vs))))
(λ (x y) (> (cdr x) (cdr y))))))
(hash-for-each ranges (λ (k v) (hash-remove! ranges k)))
(let loop ([ranges-list ranges-list] (let loop ([ranges-list ranges-list]
[i 0]) [i 0])
(cond (cond
@ -139,7 +141,7 @@ WARNING: printf is rebound in the body of the unit to always
(set! ranges-low i) (set! ranges-low i)
(set! ranges-high 1)] (set! ranges-high 1)]
[else [else
(hash-set! ranges (car ranges-list) i) (hash-cons! ranges (car ranges-list) i)
(loop (cdr ranges-list) (- i 1))]))) (loop (cdr ranges-list) (- i 1))])))
ranges-list) ranges-list)
(define/public (get-fixed-style) (define/public (get-fixed-style)
@ -393,7 +395,7 @@ WARNING: printf is rebound in the body of the unit to always
[update-one [update-one
(λ () (λ ()
(set! ranges-list #f) (set! ranges-list #f)
(hash-set! ranges l (if (eq? priority 'high) (+ ranges-high 1) (- ranges-low 1))) (hash-cons! ranges l (if (eq? priority 'high) (+ ranges-high 1) (- ranges-low 1)))
(if (eq? priority 'high) (if (eq? priority 'high)
(set! ranges-high (+ ranges-high 1)) (set! ranges-high (+ ranges-high 1))
(set! ranges-low (- ranges-low 1))))]) (set! ranges-low (- ranges-low 1))))])
@ -423,20 +425,26 @@ WARNING: printf is rebound in the body of the unit to always
(send the-color-database find-color color)))]) (send the-color-database find-color color)))])
(let ([new-todo (let ([new-todo
(λ () (λ ()
(unless (hash-ref ranges candidate #f) (let ([old-val (hash-ref ranges candidate #f)])
(error 'unhighlight-range (unless old-val
"range not found; start: ~e end: ~e color: ~a caret-space?: ~e style: ~e" (error 'unhighlight-range
start end "range not found; start: ~e end: ~e color: ~a caret-space?: ~e style: ~e"
(if (string? color) start end
(format "~s" color) (if (string? color)
(format "(red: ~a green: ~a blue: ~a)" (format "~s" color)
(send color red) (format "(red: ~a green: ~a blue: ~a)"
(send color green) (send color red)
(send color blue))) (send color green)
caret-space? (send color blue)))
style)) caret-space?
(hash-remove! ranges candidate) style))
(set! ranges-list #f))]) (let ([new-val (cdr old-val)])
(cond
[(null? new-val)
(hash-remove! ranges candidate)]
[else
(hash-set! ranges candidate new-val)]))
(set! ranges-list #f)))])
(cond (cond
[delayed-highlights? [delayed-highlights?
(set! todo (set! todo
@ -586,6 +594,8 @@ WARNING: printf is rebound in the body of the unit to always
(super-new) (super-new)
(set-autowrap-bitmap (initial-autowrap-bitmap)))) (set-autowrap-bitmap (initial-autowrap-bitmap))))
(define (hash-cons! h k v) (hash-set! h k (cons v (hash-ref h k '()))))
(define first-line<%> (define first-line<%>
(interface () (interface ()
highlight-first-line highlight-first-line

205
collects/tests/framework/text.ss
View File

@ -1,41 +1,42 @@
(module text mzscheme #lang scheme
(require "test-suite-utils.ss")
(define dummy-frame-title "dummy to avoid quitting")
(send-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
(define (test-creation frame% class name)
(test
name
(lambda (x)
(equal? x (list dummy-frame-title))) ;; ensure no frames left
(lambda ()
(let ([label
(send-sexp-to-mred
`(let ([f (instantiate (class ,frame%
(override get-editor%)
[define (get-editor%) ,class]
(super-instantiate ()))
())])
(send (send f get-editor) set-max-undo-history 10)
(send f show #t)
(send f get-label)))])
(wait-for-frame label)
(send-sexp-to-mred `(test:keystroke #\a))
(wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
(send-sexp-to-mred
`(begin
;; remove the `a' to avoid save dialog boxes (and test them, I suppose)
(send (send (get-top-level-focus-window) get-editor) undo)
(send (send (get-top-level-focus-window) get-editor) undo)
(send (send (get-top-level-focus-window) get-editor) lock #t) (require "test-suite-utils.ss")
(send (send (get-top-level-focus-window) get-editor) lock #f)))
(queue-sexp-to-mred (define dummy-frame-title "dummy to avoid quitting")
`(send (get-top-level-focus-window) close)) (send-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
(send-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))
(define (test-creation frame% class name)
#| (test
name
(lambda (x)
(equal? x (list dummy-frame-title))) ;; ensure no frames left
(lambda ()
(let ([label
(send-sexp-to-mred
`(let ([f (instantiate (class ,frame%
(override get-editor%)
[define (get-editor%) ,class]
(super-instantiate ()))
())])
(send (send f get-editor) set-max-undo-history 10)
(send f show #t)
(send f get-label)))])
(wait-for-frame label)
(send-sexp-to-mred `(test:keystroke #\a))
(wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
(send-sexp-to-mred
`(begin
;; remove the `a' to avoid save dialog boxes (and test them, I suppose)
(send (send (get-top-level-focus-window) get-editor) undo)
(send (send (get-top-level-focus-window) get-editor) undo)
(send (send (get-top-level-focus-window) get-editor) lock #t)
(send (send (get-top-level-focus-window) get-editor) lock #f)))
(queue-sexp-to-mred
`(send (get-top-level-focus-window) close))
(send-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))
#|
(test-creation 'frame:text% (test-creation 'frame:text%
'(text:basic-mixin (editor:basic-mixin text%)) '(text:basic-mixin (editor:basic-mixin text%))
'text:basic-mixin-creation) 'text:basic-mixin-creation)
@ -43,34 +44,102 @@
'text:basic% 'text:basic%
'text:basic-creation) 'text:basic-creation)
|# |#
(test-creation 'frame:text% (test-creation 'frame:text%
'(editor:file-mixin text:keymap%) '(editor:file-mixin text:keymap%)
'editor:file-mixin-creation) 'editor:file-mixin-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'text:file% 'text:file%
'text:file-creation) 'text:file-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'(text:clever-file-format-mixin text:file%) '(text:clever-file-format-mixin text:file%)
'text:clever-file-format-mixin-creation) 'text:clever-file-format-mixin-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'text:clever-file-format% 'text:clever-file-format%
'text:clever-file-format-creation) 'text:clever-file-format-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'(editor:backup-autosave-mixin text:clever-file-format%) '(editor:backup-autosave-mixin text:clever-file-format%)
'editor:backup-autosave-mixin-creation) 'editor:backup-autosave-mixin-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'text:backup-autosave% 'text:backup-autosave%
'text:backup-autosave-creation) 'text:backup-autosave-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'(text:searching-mixin text:backup-autosave%) '(text:searching-mixin text:backup-autosave%)
'text:searching-mixin-creation) 'text:searching-mixin-creation)
(test-creation 'frame:text% (test-creation 'frame:text%
'text:searching% 'text:searching%
'text:searching-creation) 'text:searching-creation)
(test-creation '(frame:searchable-mixin frame:text%) (test-creation '(frame:searchable-mixin frame:text%)
'(text:info-mixin (editor:info-mixin text:searching%)) '(text:info-mixin (editor:info-mixin text:searching%))
'text:info-mixin-creation) 'text:info-mixin-creation)
(test-creation '(frame:searchable-mixin frame:text%) (test-creation '(frame:searchable-mixin frame:text%)
'text:info% 'text:info%
'text:info-creation)) 'text:info-creation)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; testing highlight-range method
;;
(test
'highlight-range1
(lambda (x) (equal? x 1))
(λ ()
(send-sexp-to-mred
`(let ([t (new text:basic%)])
(send t insert "abc")
(send t highlight-range 1 2 "red")
(length (send t get-highlighted-ranges))))))
(test
'highlight-range2
(lambda (x) (equal? x 0))
(λ ()
(send-sexp-to-mred
`(let ([t (new text:basic%)])
(send t insert "abc")
((send t highlight-range 1 2 "red"))
(length (send t get-highlighted-ranges))))))
(test
'highlight-range3
(lambda (x) (equal? x 0))
(λ ()
(send-sexp-to-mred
`(let ([t (new text:basic%)])
(send t insert "abc")
(send t highlight-range 1 2 "red")
(send t unhighlight-range 1 2 "red")
(length (send t get-highlighted-ranges))))))
(test
'highlight-range4
(lambda (x) (equal? x 1))
(λ ()
(send-sexp-to-mred
`(let ([t (new text:basic%)])
(send t insert "abc")
(send t highlight-range 1 2 "red")
(send t highlight-range 1 2 "red")
(send t unhighlight-range 1 2 "red")
(length (send t get-highlighted-ranges))))))
(test
'highlight-range5
(lambda (x) (equal? x 0))
(λ ()
(send-sexp-to-mred
`(let ([t (new text:basic%)])
(send t insert "abc")
(send t highlight-range 1 2 "red")
(send t highlight-range 1 2 "red")
(send t unhighlight-range 1 2 "red")
(send t unhighlight-range 1 2 "red")
(length (send t get-highlighted-ranges))))))