diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt index 84a42be..3549da3 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 + 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))))))) + (for ([r (in-list (send/i range range<%> get-ranges id))]) + (restyle-range r secondary-highlight-d #t)))))))) - ;; 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)))) - - ;; 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)) +(define select-d + (make-object style-delta% 'change-weight 'bold)) + +(define underline-d + (make-object style-delta% 'change-underline #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 underline-style-delta - (let ([sd (new style-delta%)]) - (send sd set-underlined-on #t) - 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 index df84941..95c657f 100644 --- 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 index 42cde1c..13c947e 100644 --- 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%)))))))))