macro-stepper: faster step rendering

- lazily build on-click mapping
  - more precise un-styling on refresh

original commit: 199450dd0cacb2d8c3e5290b68d9b2d0aa1650fe

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 (the-callback position)
-        (send/i controller selection-manager<%> set-selected-syntax
-                (interval-map-ref mapping position #f)))
+      (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)))
+               (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)))
       (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)
+        (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)])
-           (apply-secondary-relation-styles 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))

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)

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:region-data-mixin
                  (text:hide-caret/selection-mixin
                   (text:foreground-color-mixin
                    (editor:standard-style-list-mixin text:basic%)))))))))