macro-stepper: replace clickbacks for syntax selection

fixed interval-map bug

original commit: a506d75b546a13bf95517ab68595bd63233158f7

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
+                (interval-map-ref mapping position #f)))
-                (- start start-position) (- end start-position))))
       (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)
+          (interval-map-set! mapping (+ start-position start) (+ start-position end) stx)))
-                the-clickback))))
+      (send text set-clickregion start-position end-position the-callback))
-
-    ;; 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])))))
 
     ;; refresh : -> void
     ;; Clears all highlighting and reapplies all non-foreground styles.

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%
+(define text:region-data-mixin
-  (text:hover-drawings-mixin
+  (mixin (text:basic<%>) (text:region-data<%>)
-   (text:hover-mixin
-    text:standard-style-list%)))
 
-(define text:arrows%
+    (define table (make-hasheq))
-  (text:arrows-mixin
-   (text:tacking-mixin
-    text:hover-drawings%)))
 
+    (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<%>

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
+    (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%)))))))
+                   (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))