fixed PR 9770

svn: r11999

collects/framework/private/text.ss

@@ -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)
+                   (let ([new-val (cdr old-val)])
-                 (set! ranges-list #f))])
+                     (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

collects/tests/framework/text.ss

@@ -1,10 +1,11 @@
-(module text mzscheme
+#lang scheme
-  (require "test-suite-utils.ss")
 
-  (define dummy-frame-title "dummy to avoid quitting")
+(require "test-suite-utils.ss")
-  (send-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
 
-  (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))))))