unstable: added skip-list and interval-map

unstable/contract: added rename-contract
macro-debugger: switched to use interval-map for arrows

svn: r17278

original commit: 961ece3ffe0acfcac6d889b41dee85a32f55976f

collects/macro-debugger/syntax-browser/text.ss

@@ -5,16 +5,15 @@
          scheme/gui
          drscheme/arrow
          framework/framework
+         unstable/interval-map
          unstable/gui/notify)
 
 (provide text:hover<%>
-         text:hover-identifier<%>
+         text:hover-drawings<%>
-         text:mouse-drawings<%>
          text:arrows<%>
 
          text:hover-mixin
-         text:hover-identifier-mixin
+         text:hover-drawings-mixin
-         text:mouse-drawings-mixin
          text:tacking-mixin
          text:arrows-mixin)
 
@@ -28,8 +27,8 @@
 
 (define white (send the-color-database find-color "white"))
 
-;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
+;; A Drawing is (make-drawing number number (??? -> void) (box boolean))
-(define-struct drawing (start end draw visible? tacked?) #:mutable)
+(define-struct drawing (start end draw tacked?))
 
 (define-struct idloc (start end id))
 
@@ -68,20 +67,14 @@
   (interface (text:basic<%>)
     update-hover-position))
 
-(define text:hover-identifier<%>
+(define text:hover-drawings<%>
-  (interface ()
-    get-hovered-identifier
-    set-hovered-identifier
-    listen-hovered-identifier))
-
-(define text:mouse-drawings<%>
   (interface (text:basic<%>)
-    add-mouse-drawing
+    add-hover-drawing
-    for-each-drawing
+    get-position-drawings
     delete-all-drawings))
 
 (define text:arrows<%>
-  (interface (text:mouse-drawings<%>)
+  (interface (text:hover-drawings<%>)
     add-arrow
     add-question-arrow
     add-billboard))
@@ -106,89 +99,62 @@
 
     (super-new)))
 
-(define text:hover-identifier-mixin
+(define text:hover-drawings-mixin
-  (mixin (text:hover<%>) (text:hover-identifier<%>)
+  (mixin (text:hover<%>) (text:hover-drawings<%>)
-    (define-notify hovered-identifier (new notify-box% (value #f)))
-
-    (define idlocs null)
-
-    (define/public (add-identifier-location start end id)
-      (set! idlocs (cons (make-idloc start end id) idlocs)))
-
-    (define/public (delete-all-identifier-locations)
-      (set! idlocs null)
-      (set-hovered-identifier #f))
-
-    (define/override (update-hover-position pos)
-      (super update-hover-position pos)
-      (let search ([idlocs idlocs])
-        (cond [(null? idlocs) (set-hovered-identifier #f)]
-              [(and (<= (idloc-start (car idlocs)) pos)
-                    (< pos (idloc-end (car idlocs))))
-               (set-hovered-identifier (idloc-id (car idlocs)))]
-              [else (search (cdr idlocs))])))
-    (super-new)))
-
-(define text:mouse-drawings-mixin
-  (mixin (text:hover<%>) (text:mouse-drawings<%>)
     (inherit dc-location-to-editor-location
              find-position
              invalidate-bitmap-cache)
 
-    ;; list of Drawings
+    ;; interval-map of Drawings
-    (field [drawings-list null])
+    (define drawings-list (make-numeric-interval-map))
 
-    (define/public add-mouse-drawing
+    (field [hover-position #f])
-      (case-lambda
+
-        [(start end draw)
+    (define/override (update-hover-position pos)
-         (add-mouse-drawing start end draw (box #f))]
+      (define old-pos hover-position)
-        [(start end draw tack-box)
+      (super update-hover-position pos)
-         (set! drawings-list 
+      (set! hover-position pos)
-               (cons (make-drawing start end draw #f tack-box)
+      (unless (same-drawings? old-pos pos)
-                     drawings-list))]))
+        (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))
+
+    (define/public (add-hover-drawing start end draw [tack-box (box #f)])
+      (interval-map-cons*! drawings-list
+                           start (add1 end)
+                           (make-drawing start end draw tack-box)
+                           null))
 
     (define/public (delete-all-drawings)
-      (set! drawings-list null))
+      (interval-map-remove! drawings-list -inf.0 +inf.0))
-
-    (define/public-final (for-each-drawing f)
-      (for-each f drawings-list))
 
     (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
       (super on-paint before? dc left top right bottom dx dy draw-caret)
       (unless before?
-        (for-each-drawing
+        (for ([d (get-position-drawings hover-position)])
-         (lambda (d)
+          ((drawing-draw d) this dc left top right bottom dx dy))))
-           (when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
-             ((drawing-draw d) this dc left top right bottom dx dy))))))
 
-    (define/override (update-hover-position pos)
+    (define/public (get-position-drawings pos)
-      (super update-hover-position pos)
+      (if pos (interval-map-ref drawings-list pos null) null))
-      (let ([changed? (update-visible-drawings pos)])
-        (when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))
 
-    (define/private (update-visible-drawings pos)
+    (define/private (same-drawings? old-pos pos)
-      (let ([changed? #f])
+      ;; relies on order drawings added & list-of-eq?-struct equality
-        (for-each-drawing
+      (equal? (get-position-drawings old-pos)
-         (lambda (d)
+              (get-position-drawings pos)))
-           (let ([vis? (<= (drawing-start d) pos (drawing-end d))])
-             (unless (eqv? vis? (drawing-visible? d))
-               (set-drawing-visible?! d vis?)
-               (set! changed? #t)))))
-        changed?))
 
     (super-new)))
 
 (define text:tacking-mixin
-  (mixin (text:basic<%> text:mouse-drawings<%>) ()
+  (mixin (text:basic<%> text:hover-drawings<%>) ()
     (inherit get-canvas
-             for-each-drawing)
+             get-position-drawings)
-    (inherit-field drawings-list)
+    (inherit-field hover-position)
     (super-new)
 
+    (define tacked-table (make-hasheq))
+
     (define/override (on-event ev)
       (case (send ev get-event-type)
         ((right-down)
-         (if (ormap (lambda (d) (drawing-visible? d)) drawings-list)
+         (if (pair? (get-position-drawings hover-position))
              (send (get-canvas) popup-menu
                    (make-tack/untack-menu)
                    (send ev get-x)
@@ -197,6 +163,12 @@
         (else
          (super on-event ev))))
 
+    (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+      (super on-paint before? dc left top right bottom dx dy draw-caret)
+      (unless before?
+        (for ([draw (in-hash-keys tacked-table)])
+          (draw this dc left top right bottom dx dy))))
+
     (define/private (make-tack/untack-menu)
       (define menu (new popup-menu%))
       (new menu-item% (label "Tack")
@@ -210,20 +182,18 @@
       menu)
 
     (define/private (tack)
-      (for-each-drawing
+      (for ([d (get-position-drawings hover-position)])
-       (lambda (d)
+        (hash-set! tacked-table (drawing-draw d) #t)
-         (when (drawing-visible? d)
+        (set-box! (drawing-tacked? d) #t)))
-           (set-box! (drawing-tacked? d) #t)))))
     (define/private (untack)
-      (for-each-drawing
+      (for ([d (get-position-drawings hover-position)])
-       (lambda (d)
+        (hash-remove! tacked-table (drawing-draw d))
-         (when (drawing-visible? d)
+        (set-box! (drawing-tacked? d) #f)))))
-           (set-box! (drawing-tacked? d) #f)))))))
 
 (define text:arrows-mixin
-  (mixin (text:mouse-drawings<%>) (text:arrows<%>)
+  (mixin (text:hover-drawings<%>) (text:arrows<%>)
     (inherit position-location
-             add-mouse-drawing
+             add-hover-drawing
              find-wordbreak)
 
     (define/public (add-arrow from1 from2 to1 to2 color)
@@ -256,7 +226,7 @@
                           (+ w mini mini)
                           (+ h mini mini))
                          (draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
-        (add-mouse-drawing pos1 pos2 draw)))
+        (add-hover-drawing pos1 pos2 draw)))
 
     (define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
       (define color (send the-color-database find-color color-name))
@@ -286,8 +256,8 @@
                          (send dc draw-text "?" 
                                (+ endx dx fw)
                                (- (+ endy dy) fh)))))))])
-          (add-mouse-drawing from1 from2 draw tack-box)
+          (add-hover-drawing from1 from2 draw tack-box)
-          (add-mouse-drawing to1 to2 draw tack-box))))
+          (add-hover-drawing to1 to2 draw tack-box))))
 
     (define/private (position->location p)
       (define xbox (box 0.0))
@@ -312,12 +282,44 @@
 
     (super-new)))
 
-(define text:mouse-drawings%
+(define text:hover-drawings%
-  (text:mouse-drawings-mixin
+  (text:hover-drawings-mixin
    (text:hover-mixin
     text:standard-style-list%)))
 
 (define text:arrows%
   (text:arrows-mixin
    (text:tacking-mixin
-    text:mouse-drawings%)))
+    text:hover-drawings%)))
+
+
+#|
+(define text:hover-identifier<%>
+  (interface ()
+    get-hovered-identifier
+    set-hovered-identifier
+    listen-hovered-identifier))
+
+(define text:hover-identifier-mixin
+  (mixin (text:hover<%>) (text:hover-identifier<%>)
+    (define-notify hovered-identifier (new notify-box% (value #f)))
+
+    (define idlocs null)
+
+    (define/public (add-identifier-location start end id)
+      (set! idlocs (cons (make-idloc start end id) idlocs)))
+
+    (define/public (delete-all-identifier-locations)
+      (set! idlocs null)
+      (set-hovered-identifier #f))
+
+    (define/override (update-hover-position pos)
+      (super update-hover-position pos)
+      (let search ([idlocs idlocs])
+        (cond [(null? idlocs) (set-hovered-identifier #f)]
+              [(and (<= (idloc-start (car idlocs)) pos)
+                    (< pos (idloc-end (car idlocs))))
+               (set-hovered-identifier (idloc-id (car idlocs)))]
+              [else (search (cdr idlocs))])))
+    (super-new)))
+|#

collects/macro-debugger/syntax-browser/widget.ss

@@ -253,7 +253,7 @@
 (define browser-text%
   (class (text:arrows-mixin
           (text:tacking-mixin
-           (text:mouse-drawings-mixin
+           (text:hover-drawings-mixin
             (text:hover-mixin
              (text:hide-caret/selection-mixin
               (editor:standard-style-list-mixin text:basic%))))))