commit 2ef398f6bb26cdc5a2cfe235db5db3707e702222
parent 3b182d975fe2eda44d481c3cc3368e09442f422f
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sun, 13 Dec 2009 03:06:58 +0000
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
Diffstat:
2 files changed, 95 insertions(+), 93 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/text.ss b/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:mouse-drawings<%>
+ text:hover-drawings<%>
text:arrows<%>
text:hover-mixin
- text:hover-identifier-mixin
- text:mouse-drawings-mixin
+ text:hover-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)
-(define-struct drawing (start end draw visible? tacked?) #:mutable)
+;; A Drawing is (make-drawing number number (??? -> void) (box boolean))
+(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<%>
- (interface ()
- get-hovered-identifier
- set-hovered-identifier
- listen-hovered-identifier))
-
-(define text:mouse-drawings<%>
+(define text:hover-drawings<%>
(interface (text:basic<%>)
- add-mouse-drawing
- for-each-drawing
+ add-hover-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
- (mixin (text:hover<%>) (text:hover-identifier<%>)
- (define-notify hovered-identifier (new notify-box% (value #f)))
+(define text:hover-drawings-mixin
+ (mixin (text:hover<%>) (text:hover-drawings<%>)
+ (inherit dc-location-to-editor-location
+ find-position
+ invalidate-bitmap-cache)
- (define idlocs null)
+ ;; interval-map of Drawings
+ (define drawings-list (make-numeric-interval-map))
- (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))
+ (field [hover-position #f])
(define/override (update-hover-position pos)
+ (define old-pos hover-position)
(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)))
+ (set! hover-position pos)
+ (unless (same-drawings? old-pos pos)
+ (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))
-(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
- (field [drawings-list null])
-
- (define/public add-mouse-drawing
- (case-lambda
- [(start end draw)
- (add-mouse-drawing start end draw (box #f))]
- [(start end draw tack-box)
- (set! drawings-list
- (cons (make-drawing start end draw #f tack-box)
- drawings-list))]))
+ (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))
-
- (define/public-final (for-each-drawing f)
- (for-each f drawings-list))
+ (interval-map-remove! drawings-list -inf.0 +inf.0))
(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
- (lambda (d)
- (when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
- ((drawing-draw d) this dc left top right bottom dx dy))))))
+ (for ([d (get-position-drawings hover-position)])
+ ((drawing-draw d) this dc left top right bottom dx dy))))
- (define/override (update-hover-position pos)
- (super update-hover-position pos)
- (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)
- (let ([changed? #f])
- (for-each-drawing
- (lambda (d)
- (let ([vis? (<= (drawing-start d) pos (drawing-end d))])
- (unless (eqv? vis? (drawing-visible? d))
- (set-drawing-visible?! d vis?)
- (set! changed? #t)))))
- changed?))
+ (define/public (get-position-drawings pos)
+ (if pos (interval-map-ref drawings-list pos null) null))
+
+ (define/private (same-drawings? old-pos pos)
+ ;; relies on order drawings added & list-of-eq?-struct equality
+ (equal? (get-position-drawings old-pos)
+ (get-position-drawings pos)))
(super-new)))
(define text:tacking-mixin
- (mixin (text:basic<%> text:mouse-drawings<%>) ()
+ (mixin (text:basic<%> text:hover-drawings<%>) ()
(inherit get-canvas
- for-each-drawing)
- (inherit-field drawings-list)
+ get-position-drawings)
+ (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
- (lambda (d)
- (when (drawing-visible? d)
- (set-box! (drawing-tacked? d) #t)))))
+ (for ([d (get-position-drawings hover-position)])
+ (hash-set! tacked-table (drawing-draw d) #t)
+ (set-box! (drawing-tacked? d) #t)))
(define/private (untack)
- (for-each-drawing
- (lambda (d)
- (when (drawing-visible? d)
- (set-box! (drawing-tacked? d) #f)))))))
+ (for ([d (get-position-drawings hover-position)])
+ (hash-remove! tacked-table (drawing-draw d))
+ (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-mouse-drawing to1 to2 draw tack-box))))
+ (add-hover-drawing from1 from2 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%
- (text:mouse-drawings-mixin
+(define text:hover-drawings%
+ (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)))
+|#
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/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%))))))
