commit fcd4cc32c4b0ca68d388ddc5eb31ef8c3d46bcb9
parent 627029e45add3ee9ee639e1bccd018640d169cc0
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Mon, 8 Nov 2010 20:26:43 -0700
macro-stepper: replace clickbacks for syntax selection
fixed interval-map bug
original commit: a506d75b546a13bf95517ab68595bd63233158f7
Diffstat:
3 files changed, 81 insertions(+), 35 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt
@@ -3,6 +3,7 @@
racket/gui/base
racket/list
racket/pretty
+ data/interval-map
framework
unstable/class-iop
"pretty-printer.rkt"
@@ -84,30 +85,16 @@
;; add-clickbacks : -> void
(define/private (add-clickbacks)
- (define (the-clickback editor start end)
+ (define mapping (send text get-region-mapping 'syntax))
+ (define (the-callback position)
(send/i controller selection-manager<%> set-selected-syntax
- (clickback->stx
- (- start start-position) (- end start-position))))
+ (interval-map-ref mapping position #f)))
(for ([range (send/i range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
- (send text set-clickback (+ start-position start) (+ start-position end)
- the-clickback))))
-
- ;; clickback->stx : num num -> syntax
- ;; FIXME: use vectors for treerange-subs and do binary search to narrow?
- (define/private (clickback->stx start end)
- (let ([treeranges (send/i range range<%> get-treeranges)])
- (let loop* ([treeranges treeranges])
- (for/or ([tr treeranges])
- (cond [(and (= (treerange-start tr) start)
- (= (treerange-end tr) end))
- (treerange-obj tr)]
- [(and (<= (treerange-start tr) start)
- (<= end (treerange-end tr)))
- (loop* (treerange-subs tr))]
- [else #f])))))
+ (interval-map-set! mapping (+ start-position start) (+ start-position end) stx)))
+ (send text set-clickregion start-position end-position the-callback))
;; refresh : -> void
;; Clears all highlighting and reapplies all non-foreground styles.
diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/collects/macro-debugger/syntax-browser/text.rkt
@@ -2,6 +2,7 @@
(require racket/list
racket/class
racket/gui/base
+ data/interval-map
drracket/arrow
framework/framework
data/interval-map
@@ -14,7 +15,11 @@
text:hover-mixin
text:hover-drawings-mixin
text:tacking-mixin
- text:arrows-mixin)
+ text:arrows-mixin
+ text:region-data-mixin
+ text:clickregion-mixin)
+
+(define err (current-error-port))
(define arrow-brush
(send the-brush-list find-or-create-brush "white" 'solid))
@@ -78,6 +83,10 @@
add-question-arrow
add-billboard))
+(define text:region-data<%>
+ (interface (text:basic<%>)
+ get-region-mapping))
+
(define text:hover-mixin
(mixin (text:basic<%>) (text:hover<%>)
(inherit dc-location-to-editor-location
@@ -285,16 +294,64 @@
(super-new)))
-(define text:hover-drawings%
- (text:hover-drawings-mixin
- (text:hover-mixin
- text:standard-style-list%)))
+(define text:region-data-mixin
+ (mixin (text:basic<%>) (text:region-data<%>)
+
+ (define table (make-hasheq))
+
+ (define/public (get-region-mapping key)
+ (hash-ref! table key (lambda () (make-interval-map))))
+
+ (define/augment (after-delete start len)
+ (for ([im (in-hash-values table)])
+ (interval-map-contract! im start (+ start len)))
+ (inner (void) after-delete))
+
+ (define/augment (after-insert start len)
+ (for ([im (in-hash-values table)])
+ (interval-map-expand! im start (+ start len)))
+ (inner (void) after-insert))
+
+ (super-new)))
-(define text:arrows%
- (text:arrows-mixin
- (text:tacking-mixin
- text:hover-drawings%)))
+(define clickregion-key (gensym 'text:clickregion))
+#|
+text:clickregion-mixin
+
+Like clickbacks, but:
+ - use interval-map to avoid linear search
+ (major problem w/ macro stepper and large expansions!)
+ - callback takes position of click, not (start, end)
+ - different rules for removal
+ - TODO: change cursor on mouse-over
+ - TODO: invoke callback on mouse-up
+ - TODO: extend to double-click
+|#
+
+(define text:clickregion-mixin
+ (mixin (text:region-data<%>) ()
+ (inherit get-region-mapping
+ dc-location-to-editor-location
+ find-position)
+
+ (super-new)
+ (define clickbacks (get-region-mapping clickregion-key))
+
+ (define/public (set-clickregion start end callback)
+ (if callback
+ (interval-map-set! clickbacks start end callback)
+ (interval-map-remove! clickbacks start end)))
+
+ (define/override (on-default-event ev)
+ (when (send ev button-down?)
+ (define gx (send ev get-x))
+ (define gy (send ev get-y))
+ (define-values (x y) (dc-location-to-editor-location gx gy))
+ (define pos (find-position x y))
+ (define cb (interval-map-ref clickbacks pos #f))
+ (when cb (cb pos)))
+ (super on-default-event ev))))
#|
(define text:hover-identifier<%>
diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt
@@ -244,13 +244,15 @@
(define browser-text%
(let ([browser-text-default-style-name "widget.rkt::browser-text% basic"])
- (class (text:arrows-mixin
- (text:tacking-mixin
- (text:hover-drawings-mixin
- (text:hover-mixin
- (text:hide-caret/selection-mixin
- (text:foreground-color-mixin
- (editor:standard-style-list-mixin text:basic%)))))))
+ (class (text:clickregion-mixin
+ (text:region-data-mixin
+ (text:arrows-mixin
+ (text:tacking-mixin
+ (text:hover-drawings-mixin
+ (text:hover-mixin
+ (text:hide-caret/selection-mixin
+ (text:foreground-color-mixin
+ (editor:standard-style-list-mixin text:basic%)))))))))
(inherit set-autowrap-bitmap get-style-list)
(define/override (default-style-name) browser-text-default-style-name)
(super-new (auto-wrap #t))
