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

22
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)
(unless 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]
[i 0])
(cond
@ -139,7 +141,7 @@ WARNING: printf is rebound in the body of the unit to always
(set! ranges-low i)
(set! ranges-high 1)]
[else
(hash-set! ranges (car ranges-list) i)
(hash-cons! ranges (car ranges-list) i)
(loop (cdr ranges-list) (- i 1))])))
ranges-list)
(define/public (get-fixed-style)
@ -393,7 +395,7 @@ WARNING: printf is rebound in the body of the unit to always
[update-one
(λ ()
(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)
(set! ranges-high (+ ranges-high 1))
(set! ranges-low (- ranges-low 1))))])
@ -423,7 +425,8 @@ WARNING: printf is rebound in the body of the unit to always
(send the-color-database find-color color)))])
(let ([new-todo
(λ ()
(unless (hash-ref ranges candidate #f)
(let ([old-val (hash-ref ranges candidate #f)])
(unless old-val
(error 'unhighlight-range
"range not found; start: ~e end: ~e color: ~a caret-space?: ~e style: ~e"
start end
@ -435,8 +438,13 @@ WARNING: printf is rebound in the body of the unit to always
(send color blue)))
caret-space?
style))
(hash-remove! ranges candidate)
(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
[delayed-highlights?
(set! todo
@ -586,6 +594,8 @@ WARNING: printf is rebound in the body of the unit to always
(super-new)
(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<%>
(interface ()
highlight-first-line

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

@ -1,10 +1,11 @@
(module text mzscheme
(require "test-suite-utils.ss")
#lang scheme
(define dummy-frame-title "dummy to avoid quitting")
(send-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
(require "test-suite-utils.ss")
(define (test-creation frame% class name)
(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)
@ -35,7 +36,7 @@
`(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%
'(text:basic-mixin (editor:basic-mixin text%))
'text:basic-mixin-creation)
@ -43,34 +44,102 @@
'text:basic%
'text:basic-creation)
|#
(test-creation 'frame:text%
(test-creation 'frame:text%
'(editor:file-mixin text:keymap%)
'editor:file-mixin-creation)
(test-creation 'frame:text%
(test-creation 'frame:text%
'text:file%
'text:file-creation)
(test-creation 'frame:text%
(test-creation 'frame:text%
'(text:clever-file-format-mixin text:file%)
'text:clever-file-format-mixin-creation)
(test-creation 'frame:text%
(test-creation 'frame:text%
'text:clever-file-format%
'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-creation)
(test-creation 'frame:text%
(test-creation 'frame:text%
'text:backup-autosave%
'text:backup-autosave-creation)
(test-creation 'frame:text%
(test-creation 'frame:text%
'(text:searching-mixin text:backup-autosave%)
'text:searching-mixin-creation)
(test-creation 'frame:text%
(test-creation 'frame:text%
'text:searching%
'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-creation)
(test-creation '(frame:searchable-mixin frame:text%)
(test-creation '(frame:searchable-mixin frame:text%)
'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))))))