Macro stepper: tackable arrows

svn: r5930

collects/macro-debugger/syntax-browser/text.ss

@@ -48,7 +48,8 @@
   (define text:drawings<%>
     (interface (text:basic<%>)
       add-drawings
-      delete-drawings))
+      delete-drawings
+      delete-all-drawings))
 
   (define text:mouse-drawings<%>
     (interface (text:drawings<%>)
@@ -72,6 +73,10 @@
       (define/public (delete-drawings key)
         (hash-table-remove! draw-table key))
 
+      (define/public (delete-all-drawings)
+        (for-each (lambda (key) (hash-table-remove! draw-table key))
+                  (hash-table-map draw-table (lambda (k v) k))))
+
       (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?
@@ -83,6 +88,9 @@
 
       (super-new)))
 
+  ;; A Drawing is (make-drawing number number (??? -> void))
+  (define-struct drawing (start end draw) #f)
+
   (define text:mouse-drawings-mixin
     (mixin (text:drawings<%>) (text:mouse-drawings<%>)
       (inherit dc-location-to-editor-location
@@ -91,17 +99,23 @@
                add-drawings
                delete-drawings)
 
-      (define inactive-list null)
+      ;; lists of Drawings
-      (define active-list null)
+      (field [inactive-list null]
+             [active-list null])
       
       (define/public (add-mouse-drawing start end draw)
         (set! inactive-list 
-              (cons (cons (cons start end) draw)
+              (cons (make-drawing start end draw)
                     inactive-list)))
       
       (define/public (delete-mouse-drawings)
         (set! inactive-list null))
 
+      (define/override (delete-all-drawings)
+        (super delete-all-drawings)
+        (set! inactive-list null)
+        (set! active-list null))
+
       (define/override (on-default-event ev)
         (define gx (send ev get-x))
         (define gy (send ev get-y))
@@ -111,12 +125,13 @@
         (case (send ev get-event-type)
           ((enter motion)
            (let ([new-active-annotations
-                  (filter (lambda (rec) (<= (caar rec) pos (cdar rec)))
+                  (filter (lambda (rec)
+                            (<= (drawing-start rec) pos (drawing-end rec)))
                           inactive-list)])
              (unless (equal? active-list new-active-annotations)
                (set! active-list new-active-annotations)
                (delete-drawings 'mouse-over)
-               (add-drawings 'mouse-over (map cdr active-list))
+               (add-drawings 'mouse-over (map drawing-draw active-list))
                (invalidate-bitmap-cache))))
           ((leave)
            (unless (null? active-list)
@@ -132,11 +147,11 @@
     (mixin (text:mouse-drawings<%>) (text:arrows<%>)
       (inherit position-location
                add-mouse-drawing
-               find-wordbreak)
+               find-wordbreak
-      
+               add-drawings
-      (define (?-font dc)
+               delete-drawings
-        (let ([size (send (send dc get-font) get-point-size)])
+               get-canvas)
-          (send the-font-list find-or-create-font size 'default 'normal 'bold)))
+      (inherit-field active-list inactive-list)
 
       (define/public (add-arrow from1 from2 to1 to2 color)
         (internal-add-arrow from1 from2 to1 to2 color #f))
@@ -181,23 +196,42 @@
         (position-location p xbox ybox)
         (values (unbox xbox) (unbox ybox)))
 
-      #;
+      (define/override (on-event ev)
-      (define/public (add-dot position)
+        (case (send ev get-event-type)
-        (define-values (pos1 pos2) (word-at position))
+          ((right-down)
-        (add-mouse-drawing pos1 pos2
+           (let ([arrows active-list])
-                           (lambda (text dc left top right bottom dx dy)
+             (if (pair? arrows)
-                             (let-values ([(x y) (position->location position)])
+                 (send (get-canvas) popup-menu
-                               (send dc draw-ellipse
+                       (make-tack/untack-menu)
-                                     (+ x dx)
+                       (send ev get-x)
-                                     (+ y dy)
+                       (send ev get-y))
-                                     20 20)))))
+                 (super on-event ev))))
+          (else
+           (super on-event ev))))
 
-      #;
+      (define/private (make-tack/untack-menu)
-      (define/private (word-at p)
+        (define menu (new popup-menu%))
-        (define sbox (box p))
+        (new menu-item% (label "Tack arrows")
-        (define ebox (box p))
+             (parent menu)
-        (find-wordbreak sbox ebox 'caret)
+             (callback
-        (values (unbox sbox) (unbox ebox)))
+              (lambda _ (tack-arrows))))
+        (new menu-item% (label "Untack arrows")
+             (parent menu)
+             (callback
+              (lambda _ (untack-arrows))))
+        menu)
+
+      (define/private (tack-arrows)
+        (for-each (lambda (arrow) 
+                    (add-drawings (drawing-draw arrow) (list (drawing-draw arrow))))
+                  active-list))
+      (define/private (untack-arrows)
+        (for-each (lambda (arrow) (delete-drawings (drawing-draw arrow)))
+                  active-list))
+
+      (define/private (?-font dc)
+        (let ([size (send (send dc get-font) get-point-size)])
+          (send the-font-list find-or-create-font size 'default 'normal 'bold)))
 
       (super-new)))
 
@@ -208,38 +242,6 @@
   (define text:arrows%
     (text:arrows-mixin text:mouse-drawings%))
 
-  #;
-  (define text:crazy%
-    (class text:arrows%
-      (inherit add-arrow
-               find-position
-               invalidate-bitmap-cache)
-      (define loc #f)
-      (define prev-pos #f)
-      
-      (define/override (on-default-event ev)
-        (define x (send ev get-x))
-        (define y (send ev get-y))
-        (case (send ev get-event-type)
-          ((motion)
-           (set! loc (cons x y))
-           (when prev-pos (invalidate-bitmap-cache)))
-          ((left-down)
-           (let ([pos (find-position x y)])
-             (if prev-pos
-                 (when (and pos (not (= pos prev-pos)))
-                   (add-arrow prev-pos pos "red")
-                   (set! prev-pos #f))
-                 (set! prev-pos pos)))))
-        (super on-default-event ev))
-      
-      (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?
-          (when (and loc prev-pos)
-            (send dc draw-ellipse (- (car loc) 5) (- (cdr loc) 5) 10 10))))
-      (super-new)))
-
   #;
   (begin
     (define f (new frame% (label "testing") (width 100) (height 100)))

collects/macro-debugger/syntax-browser/widget.ss

@@ -141,7 +141,7 @@
           (define/public (erase-all)
             (with-unlock -text
               (send -text erase)
-              (send -text delete-mouse-drawings))
+              (send -text delete-all-drawings))
             (send controller erase))
           
           (define/public (select-syntax stx)