fixed PR 9770
svn: r11999 original commit: 4c010b7d4a6f28b1362adbe07f4871aa7593db11
This commit is contained in:
Robby Findler
parent
5985096912
commit
766256f4c4
|
|
@ -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,20 +425,26 @@ 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)
|
||||
(error 'unhighlight-range
|
||||
"range not found; start: ~e end: ~e color: ~a caret-space?: ~e style: ~e"
|
||||
start end
|
||||
(if (string? color)
|
||||
(format "~s" color)
|
||||
(format "(red: ~a green: ~a blue: ~a)"
|
||||
(send color red)
|
||||
(send color green)
|
||||
(send color blue)))
|
||||
caret-space?
|
||||
style))
|
||||
(hash-remove! ranges candidate)
|
||||
(set! ranges-list #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
|
||||
(if (string? color)
|
||||
(format "~s" color)
|
||||
(format "(red: ~a green: ~a blue: ~a)"
|
||||
(send color red)
|
||||
(send color green)
|
||||
(send color blue)))
|
||||
caret-space?
|
||||
style))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -1,41 +1,42 @@
|
|||
(module text mzscheme
|
||||
(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)
|
||||
#lang scheme
|
||||
|
||||
(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)))))))
|
||||
|
||||
#|
|
||||
(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)
|
||||
(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%
|
||||
'(text:basic-mixin (editor:basic-mixin text%))
|
||||
'text:basic-mixin-creation)
|
||||
|
|
@ -43,34 +44,102 @@
|
|||
'text:basic%
|
||||
'text:basic-creation)
|
||||
|#
|
||||
(test-creation 'frame:text%
|
||||
'(editor:file-mixin text:keymap%)
|
||||
'editor:file-mixin-creation)
|
||||
|
||||
(test-creation 'frame:text%
|
||||
'text:file%
|
||||
'text:file-creation)
|
||||
(test-creation 'frame:text%
|
||||
'(text:clever-file-format-mixin text:file%)
|
||||
'text:clever-file-format-mixin-creation)
|
||||
(test-creation 'frame:text%
|
||||
'text:clever-file-format%
|
||||
'text:clever-file-format-creation)
|
||||
(test-creation 'frame:text%
|
||||
'(editor:backup-autosave-mixin text:clever-file-format%)
|
||||
'editor:backup-autosave-mixin-creation)
|
||||
(test-creation 'frame:text%
|
||||
'text:backup-autosave%
|
||||
'text:backup-autosave-creation)
|
||||
(test-creation 'frame:text%
|
||||
'(text:searching-mixin text:backup-autosave%)
|
||||
'text:searching-mixin-creation)
|
||||
(test-creation 'frame:text%
|
||||
'text:searching%
|
||||
'text:searching-creation)
|
||||
(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%)
|
||||
'text:info%
|
||||
'text:info-creation))
|
||||
(test-creation 'frame:text%
|
||||
'(editor:file-mixin text:keymap%)
|
||||
'editor:file-mixin-creation)
|
||||
|
||||
(test-creation 'frame:text%
|
||||
'text:file%
|
||||
'text:file-creation)
|
||||
(test-creation 'frame:text%
|
||||
'(text:clever-file-format-mixin text:file%)
|
||||
'text:clever-file-format-mixin-creation)
|
||||
(test-creation 'frame:text%
|
||||
'text:clever-file-format%
|
||||
'text:clever-file-format-creation)
|
||||
(test-creation 'frame:text%
|
||||
'(editor:backup-autosave-mixin text:clever-file-format%)
|
||||
'editor:backup-autosave-mixin-creation)
|
||||
(test-creation 'frame:text%
|
||||
'text:backup-autosave%
|
||||
'text:backup-autosave-creation)
|
||||
(test-creation 'frame:text%
|
||||
'(text:searching-mixin text:backup-autosave%)
|
||||
'text:searching-mixin-creation)
|
||||
(test-creation 'frame:text%
|
||||
'text:searching%
|
||||
'text:searching-creation)
|
||||
(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%)
|
||||
'text:info%
|
||||
'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))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user