From fcd4cc32c4b0ca68d388ddc5eb31ef8c3d46bcb9 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 8 Nov 2010 20:26:43 -0700 Subject: [PATCH] macro-stepper: replace clickbacks for syntax selection fixed interval-map bug original commit: a506d75b546a13bf95517ab68595bd63233158f7 --- .../macro-debugger/syntax-browser/display.rkt | 25 ++----- .../macro-debugger/syntax-browser/text.rkt | 75 ++++++++++++++++--- .../macro-debugger/syntax-browser/widget.rkt | 16 ++-- 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 index e44436d..84a42be 100644 --- 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 index a5b546a..9f06fa2 100644 --- 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 text:arrows% - (text:arrows-mixin - (text:tacking-mixin - text:hover-drawings%))) + (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 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 index 085f966..42cde1c 100644 --- 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))