From 766256f4c43eaed6742161713bced5e37214a6a3 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 13 Oct 2008 00:53:23 +0000
Subject: [PATCH] fixed PR 9770

svn: r11999

original commit: 4c010b7d4a6f28b1362adbe07f4871aa7593db11
---
 collects/framework/private/text.ss |  44 ++++---
 collects/tests/framework/text.ss   | 205 +++++++++++++++++++----------
 2 files changed, 164 insertions(+), 85 deletions(-)

diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss
index fc8102db..ff0a3378 100644
--- a/collects/framework/private/text.ss
+++ b/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,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
diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss
index 09671420..b276ac36 100644
--- a/collects/tests/framework/text.ss
+++ b/collects/tests/framework/text.ss
@@ -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))))))