commit 847c0c67a738eeb1bc88a77d8989ad79174cd7db
parent 0cad27438deab291f02f2e4e3b88705b00114f95
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 9 Nov 2010 00:04:14 -0700
macro-stepper: faster step rendering
- lazily build on-click mapping
- more precise un-styling on refresh
original commit: 199450dd0cacb2d8c3e5290b68d9b2d0aa1650fe
Diffstat:
3 files changed, 135 insertions(+), 116 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
+ racket/promise
data/interval-map
framework
unstable/class-iop
@@ -71,42 +72,68 @@
(define base-style
(code-style text (send/i config config<%> get-syntax-font-size)))
+ ;; on-next-refresh : (listof (cons stx style-delta))
+ ;; Styles to be applied on next refresh only. (eg, underline)
+ (define on-next-refresh null)
+
+ ;; extra-styles : hash[stx => (listof style-delta)]
+ ;; Styles to be re-applied on every refresh.
(define extra-styles (make-hasheq))
- (define auto-refresh? #f) ;; FIXME: delete or make init arg
+ ;; to-undo-styles : (listof (cons nat nat))
+ ;; Ranges to unbold or unhighlight when selection changes.
+ ;; FIXME: ought to be managed by text:region-data (to auto-update ranges)
+ ;; until then, positions are relative
+ (define to-undo-styles null)
;; initialize : -> void
(define/private (initialize)
(uninterruptible
(send text change-style base-style start-position end-position #f))
(uninterruptible (apply-primary-partition-styles))
- (uninterruptible (add-clickbacks))
- (when auto-refresh? (refresh)))
+ (uninterruptible (add-clickbacks)))
;; add-clickbacks : -> void
(define/private (add-clickbacks)
(define mapping (send text get-region-mapping 'syntax))
+ (define lazy-interval-map-init
+ (delay
+ (uninterruptible
+ (for ([range (send/i range range<%> all-ranges)])
+ (let ([stx (range-obj range)]
+ [start (range-start range)]
+ [end (range-end range)])
+ (interval-map-set! mapping (+ start-position start) (+ start-position end) stx))))))
(define (the-callback position)
+ (force lazy-interval-map-init)
(send/i controller selection-manager<%> set-selected-syntax
(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)])
- (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.
(define/public (refresh)
- (uninterruptible
- (with-unlock text
- (send text change-style (unhighlight-d) start-position end-position)
- (apply-extra-styles)
- (let ([selected-syntax
- (send/i controller selection-manager<%>
- get-selected-syntax)])
- (apply-secondary-relation-styles selected-syntax)
+ (with-unlock text
+ (uninterruptible
+ (let ([undo-select/highlight-d (get-undo-select/highlight-d)])
+ (for ([r (in-list to-undo-styles)])
+ (send text change-style undo-select/highlight-d
+ (relative->text-position (car r))
+ (relative->text-position (cdr r)))))
+ (set! to-undo-styles null))
+ (uninterruptible
+ (for ([stx+delta (in-list on-next-refresh)])
+ (for ([r (in-list (send/i range range<%> get-ranges (car stx+delta)))])
+ (restyle-range r (cdr stx+delta) #f)))
+ (set! on-next-refresh null))
+ (uninterruptible
+ (apply-extra-styles))
+ (let ([selected-syntax
+ (send/i controller selection-manager<%>
+ get-selected-syntax)])
+ (uninterruptible
+ (apply-secondary-relation-styles selected-syntax))
+ (uninterruptible
(apply-selection-styles selected-syntax)))))
;; get-range : -> range<%>
@@ -120,22 +147,16 @@
;; highlight-syntaxes : (list-of syntax) string -> void
(define/public (highlight-syntaxes stxs hi-color)
- (let ([style-delta (highlight-style-delta hi-color #f)])
- (for ([stx stxs])
- (add-extra-styles stx (list style-delta))))
- (when auto-refresh? (refresh)))
+ (let ([delta (highlight-style-delta hi-color)])
+ (for ([stx (in-list stxs)])
+ (hash-set! extra-styles stx
+ (cons delta (hash-ref extra-styles stx null))))))
;; underline-syntaxes : (listof syntax) -> void
(define/public (underline-syntaxes stxs)
- (for ([stx stxs])
- (add-extra-styles stx (list underline-style-delta)))
- (when auto-refresh? (refresh)))
-
- ;; add-extra-styles : syntax (listof style) -> void
- (define/public (add-extra-styles stx styles)
- (hash-set! extra-styles stx
- (append (hash-ref extra-styles stx null)
- styles)))
+ (for ([stx (in-list stxs)])
+ (set! on-next-refresh
+ (cons (cons stx underline-d) on-next-refresh))))
;; Primary styles
;; (Done once on initialization, never repeated)
@@ -187,10 +208,16 @@
;; apply-extra-styles : -> void
;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles)
- (for ([(stx style-deltas) extra-styles])
- (for ([r (send/i range range<%> get-ranges stx)])
- (for ([style-delta style-deltas])
- (restyle-range r style-delta)))))
+ (for ([(stx deltas) (in-hash extra-styles)])
+ (for ([r (in-list (send/i range range<%> get-ranges stx))])
+ (for ([delta (in-list deltas)])
+ (restyle-range r delta #t)))))
+
+ ;; apply-selection-styles : syntax -> void
+ ;; Styles subterms eq to the selected syntax
+ (define/private (apply-selection-styles selected-syntax)
+ (for ([r (in-list (send/i range range<%> get-ranges selected-syntax))])
+ (restyle-range r select-d #t)))
;; apply-secondary-relation-styles : selected-syntax -> void
;; If the selected syntax is an identifier, then styles all identifiers
@@ -200,25 +227,17 @@
(let* ([name+relation
(send/i controller secondary-relation<%>
get-identifier=?)]
- [relation (and name+relation (cdr name+relation))])
+ [relation (and name+relation (cdr name+relation))]
+ [secondary-highlight-d (get-secondary-highlight-d)])
(when relation
- (for ([id (send/i range range<%> get-identifier-list)])
+ (for ([id (in-list (send/i range range<%> get-identifier-list))])
(when (relation selected-syntax id)
- (draw-secondary-connection id)))))))
-
- ;; apply-selection-styles : syntax -> void
- ;; Styles subterms eq to the selected syntax
- (define/private (apply-selection-styles selected-syntax)
- (for ([r (send/i range range<%> get-ranges selected-syntax)])
- (restyle-range r (select-highlight-d))))
-
- ;; draw-secondary-connection : syntax -> void
- (define/private (draw-secondary-connection stx2)
- (for ([r (send/i range range<%> get-ranges stx2)])
- (restyle-range r (select-sub-highlight-d))))
+ (for ([r (in-list (send/i range range<%> get-ranges id))])
+ (restyle-range r secondary-highlight-d #t))))))))
- ;; restyle-range : (cons num num) style-delta% -> void
- (define/private (restyle-range r style)
+ ;; restyle-range : (cons num num) style-delta% boolean -> void
+ (define/private (restyle-range r style need-undo?)
+ (when need-undo? (set! to-undo-styles (cons r to-undo-styles)))
(send text change-style style
(relative->text-position (car r))
(relative->text-position (cdr r))))
@@ -352,34 +371,38 @@
;; Styles
-(define (highlight-style-delta raw-color em?
- #:translate-color? [translate-color? #t])
- (let* ([sd (new style-delta%)])
- (unless em?
- (send sd set-delta-background
- (if translate-color? (translate-color raw-color) raw-color)))
- (when em? (send sd set-weight-on 'bold))
- (unless em?
- ;; (send sd set-underlined-off #t)
- (send sd set-weight-off 'bold))
- sd))
+(define select-d
+ (make-object style-delta% 'change-weight 'bold))
+
+(define underline-d
+ (make-object style-delta% 'change-underline #t))
-(define underline-style-delta
- (let ([sd (new style-delta%)])
- (send sd set-underlined-on #t)
+(define (highlight-style-delta raw-color #:translate-color? [translate-color? #t])
+ (let ([sd (new style-delta%)]
+ [color (if translate-color? (translate-color raw-color) raw-color)])
+ (send sd set-delta-background color)
sd))
-(define (mk-2-constant-style bow-color em? [wob-color (translate-color bow-color)])
- (let ([wob-version (highlight-style-delta wob-color em? #:translate-color? #f)]
- [bow-version (highlight-style-delta bow-color em? #:translate-color? #f)])
+(define (mk-2-constant-style bow-color [wob-color (translate-color bow-color)])
+ (let ([wob-version (highlight-style-delta wob-color #:translate-color? #f)]
+ [bow-version (highlight-style-delta bow-color #:translate-color? #f)])
(λ ()
(if (pref:invert-colors?)
wob-version
bow-version))))
-(define select-highlight-d
- (mk-2-constant-style "yellow" #t "darkgoldenrod"))
-(define select-sub-highlight-d
- (mk-2-constant-style "yellow" #f "darkgoldenrod"))
+(define get-secondary-highlight-d
+ (mk-2-constant-style "yellow" "darkgoldenrod"))
-(define unhighlight-d (mk-2-constant-style "white" #f #|"black"|#))
+#|
+(define undo-select-d
+ (make-object style-delta% 'change-weight 'normal))
+(define get-undo-highlight-d
+ (mk-2-constant-style "white" "black"))
+|#
+
+(define (get-undo-select/highlight-d)
+ (let ([sd (make-object style-delta% 'change-weight 'normal)]
+ [bg (if (pref:invert-colors?) "black" "white")])
+ (send sd set-delta-background bg)
+ sd))
diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/collects/macro-debugger/syntax-browser/text.rkt
@@ -67,6 +67,12 @@
(send dc set-text-background old-background)
(send dc set-text-mode old-mode))))
+;; Interfaces
+
+(define text:region-data<%>
+ (interface (text:basic<%>)
+ get-region-mapping))
+
(define text:hover<%>
(interface (text:basic<%>)
update-hover-position))
@@ -74,8 +80,7 @@
(define text:hover-drawings<%>
(interface (text:basic<%>)
add-hover-drawing
- get-position-drawings
- delete-all-drawings))
+ get-position-drawings))
(define text:arrows<%>
(interface (text:hover-drawings<%>)
@@ -83,9 +88,27 @@
add-question-arrow
add-billboard))
-(define text:region-data<%>
- (interface (text:basic<%>)
- get-region-mapping))
+;; Mixins
+
+(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:hover-mixin
(mixin (text:basic<%>) (text:hover<%>)
@@ -108,13 +131,15 @@
(super-new)))
(define text:hover-drawings-mixin
- (mixin (text:hover<%>) (text:hover-drawings<%>)
+ (mixin (text:hover<%> text:region-data<%>) (text:hover-drawings<%>)
(inherit dc-location-to-editor-location
find-position
- invalidate-bitmap-cache)
+ invalidate-bitmap-cache
+ get-region-mapping)
+ (super-new)
;; interval-map of Drawings
- (define drawings-list (make-interval-map))
+ (define drawings-list (get-region-mapping 'hover-drawings))
(field [hover-position #f])
@@ -132,9 +157,6 @@
drawing
null)))
- (define/public (delete-all-drawings)
- (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?
@@ -147,9 +169,7 @@
(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)))
+ (get-position-drawings pos)))))
(define text:tacking-mixin
(mixin (text:basic<%> text:hover-drawings<%>) ()
@@ -303,28 +323,6 @@
(super-new)))
-(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 clickregion-key (gensym 'text:clickregion))
-
#|
text:clickregion-mixin
@@ -335,7 +333,6 @@ Like clickbacks, but:
- different rules for removal
- TODO: extend to double-click
|#
-
(define text:clickregion-mixin
(mixin (text:region-data<%>) ()
(inherit get-admin
@@ -344,7 +341,7 @@ Like clickbacks, but:
find-position)
(super-new)
- (define clickbacks (get-region-mapping clickregion-key))
+ (define clickbacks (get-region-mapping 'clickregion))
(define tracking #f)
(define/public (set-clickregion start end callback)
diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt
@@ -203,8 +203,7 @@
(define/public (erase-all)
(with-unlock -text
- (send -text erase)
- (send -text delete-all-drawings))
+ (send -text erase))
(send/i controller displays-manager<%> remove-all-syntax-displays))
(define/public (get-text) -text)
@@ -245,11 +244,11 @@
(define browser-text%
(let ([browser-text-default-style-name "widget.rkt::browser-text% basic"])
(class (text:clickregion-mixin
- (text:region-data-mixin
- (text:arrows-mixin
- (text:tacking-mixin
- (text:hover-drawings-mixin
- (text:hover-mixin
+ (text:arrows-mixin
+ (text:tacking-mixin
+ (text:hover-drawings-mixin
+ (text:hover-mixin
+ (text:region-data-mixin
(text:hide-caret/selection-mixin
(text:foreground-color-mixin
(editor:standard-style-list-mixin text:basic%)))))))))
