macro-stepper: syntax display speedups (?)

switched from style-deltas to styles
  tree traversal of ranges, avoid idempotent style changes

svn: r16407

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

@@ -1,19 +1,35 @@
 #lang scheme/base
 (require scheme/class
          scheme/gui
-         scheme/match
+         scheme/list
          macro-debugger/util/class-iop
+         (only-in mzlib/etc begin-with-definitions)
          "pretty-printer.ss"
          "interfaces.ss"
          "util.ss")
 (provide print-syntax-to-editor
          code-style)
 
+(define TIME-PRINTING? #f)
+
+(define-syntax-rule (now)
+  (if TIME-PRINTING?
+      (current-inexact-milliseconds)
+      0))
+
+(define eprintf
+  (if TIME-PRINTING?
+      (let ([eport (current-error-port)])
+        (lambda (fmt . args) (apply fprintf eport fmt args)))
+      void))
+
 ;; FIXME: assumes text never moves
 
 ;; print-syntax-to-editor : syntax text controller<%> config number number
 ;;                          -> display<%>
 (define (print-syntax-to-editor stx text controller config columns insertion-point)
+  (begin-with-definitions
+   (define **entry (now))
    (define output-port (open-output-string/count-lines))
    (define range
      (pretty-print-syntax stx output-port 
@@ -21,23 +37,39 @@
                           (send: config config<%> get-colors)
                           (send: config config<%> get-suffix-option)
                           columns))
+   (define **range (now))
    (define output-string (get-output-string output-port))
    (define output-length (sub1 (string-length output-string))) ;; skip final newline
    (fixup-parentheses output-string range)
-  (let ([display
+   (define **fixup (now))
+   (define display
      (new display%
           (text text)
           (controller controller)
           (config config)
           (range range)
+          (base-style (standard-font text config))
           (start-position insertion-point)
-              (end-position (+ insertion-point output-length)))])
+          (end-position (+ insertion-point output-length))))
    (send text begin-edit-sequence)
+   (define **editing (now))
    (send text insert output-length output-string insertion-point)
+   (define **inserted (now))
    (add-clickbacks text range controller insertion-point)
-    (set-standard-font text config insertion-point (+ insertion-point output-length))
+   (define **clickbacks (now))
    (send display initialize)
+   (define **colorize (now))
    (send text end-edit-sequence)
+   (define **finished (now))
+   (when TIME-PRINTING?
+     (eprintf "** pretty-print: ~s\n" (- **range **entry))
+     (eprintf "** fixup, begin-edit-sequence: ~s\n" (- **editing **range))
+     (eprintf "** > insert: ~s\n" (- **inserted **editing))
+     (eprintf "** > clickback: ~s\n" (- **clickbacks **inserted))
+     (eprintf "** > colorize: ~s\n" (- **colorize **clickbacks))
+     (eprintf "** finish: ~s\n" (- **finished **colorize))
+     (eprintf "** total: ~s\n" (- **finished **entry))
+     (eprintf "\n"))
    display))
 
 ;; add-clickbacks : text% range% controller<%> number -> void
@@ -51,11 +83,8 @@
               (send: controller selection-manager<%>
                      set-selected-syntax stx))))))
 
-;; set-standard-font : text% config number number -> void
+(define (standard-font text config)
-(define (set-standard-font text config start end)
+  (code-style text (send: config config<%> get-syntax-font-size)))
-  (send text change-style
-        (code-style text (send: config config<%> get-syntax-font-size))
-        start end))
 
 ;; display%
 (define display%
@@ -64,6 +93,7 @@
                  [config config<%>]
                  [range range<%>])
     (init-field text
+                base-style
                 start-position
                 end-position)
 
@@ -71,6 +101,7 @@
 
     ;; initialize : -> void
     (define/public (initialize)
+      (send text change-style base-style start-position end-position #f)
       (apply-primary-partition-styles)
       (refresh))
 
@@ -125,26 +156,30 @@
     ;; Changes the foreground color according to the primary partition.
     ;; Only called once, when the syntax is first drawn.
     (define/private (apply-primary-partition-styles)
+      (define style-list (send text get-style-list))
       (define (color-style color)
         (let ([delta (new style-delta%)])
           (send delta set-delta-foreground color)
-          delta))
+          (send style-list find-or-create-style base-style delta)))
       (define color-styles
         (list->vector (map color-style (send: config config<%> get-colors))))
       (define overflow-style (color-style "darkgray"))
       (define color-partition
         (send: controller mark-manager<%> get-primary-partition))
       (define offset start-position)
-      (for-each
+      ;; Optimization: don't call change-style when new style = old style
-       (lambda (range)
+      (let tr*loop ([trs (send: range range<%> get-treeranges)] [old-style #f])
-         (let ([stx (range-obj range)]
+        (for ([tr trs])
-               [start (range-start range)]
+          (define stx (treerange-obj tr))
-               [end (range-end range)])
+          (define start (treerange-start tr))
-           (send text change-style
+          (define end (treerange-end tr))
-                 (primary-style stx color-partition color-styles overflow-style)
+          (define subs (treerange-subs tr))
-                 (+ offset start)
+          (define new-style
-                 (+ offset end))))
+            (primary-style stx color-partition color-styles overflow-style))
-       (send: range range<%> all-ranges)))
+          (unless (eq? old-style new-style)
+            (send text change-style new-style (+ offset start) (+ offset end) #f))
+          (tr*loop subs new-style)))
+      (void))
 
     ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
     ;;               -> style-delta%

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

@@ -109,6 +109,9 @@
   (;; get-ranges : datum -> (list-of (cons number number))
    get-ranges
 
+   ;; get-treeranges : -> (listof TreeRange)
+   get-treeranges
+
    ;; all-ranges : (list-of Range)
    ;; Sorted outermost-first
    all-ranges
@@ -120,6 +123,8 @@
 ;; A Range is (make-range datum number number)
 (define-struct range (obj start end))
 
+;; A TreeRange is (make-treerange syntax nat nat (listof TreeRange))
+(define-struct treerange (obj start end subs))
 
 ;; syntax-prefs<%>
 (define-interface syntax-prefs<%> ()

collects/macro-debugger/syntax-browser/pretty-printer.ss

@@ -29,8 +29,10 @@
     (let-values ([(line column position) (port-next-location port)])
       (sub1 position)))
   (define (pp-pre-hook obj port)
+    (send range-builder push! obj (current-position))
     (send range-builder set-start obj (current-position)))
   (define (pp-post-hook obj port)
+    (send range-builder pop! (flat=>stx obj) (current-position))
     (let ([start (send range-builder get-start obj)]
           [end (current-position)]
           [stx (flat=>stx obj)])
@@ -110,16 +112,40 @@
       (hash-set! starts obj n))
 
     (define/public (get-start obj)
-      (hash-ref starts obj (lambda _ #f)))
+      (hash-ref starts obj #f))
 
     (define/public (add-range obj range)
       (hash-set! ranges obj (cons range (get-ranges obj))))
 
     (define (get-ranges obj)
-      (hash-ref ranges obj (lambda () null)))
+      (hash-ref ranges obj null))
 
     (define/public (range:get-ranges) ranges)
 
+    ;; ----
+
+    (define/public (get-subs)
+      working-subs)
+
+    (define working-start #f)
+    (define working-subs null)
+    (define saved-starts null)
+    (define saved-subss null)
+
+    (define/public (push! obj start)
+      (set! saved-starts (cons working-start saved-starts))
+      (set! saved-subss (cons working-subs saved-subss))
+      (set! working-start start)
+      (set! working-subs null))
+
+    (define/public (pop! stx end)
+      (define latest (make-treerange stx working-start end (reverse working-subs)))
+      (set! working-start (car saved-starts))
+      (set! working-subs (car saved-subss))
+      (set! saved-starts (cdr saved-starts))
+      (set! saved-subss (cdr saved-subss))
+      (set! working-subs (cons latest working-subs)))
+
     (super-new)))
 
 ;; range%
@@ -130,17 +156,22 @@
     (super-new)
 
     (define ranges (hash-copy (send range-builder range:get-ranges)))
+    (define subs (reverse (send range-builder get-subs)))
 
     (define/public (get-ranges obj)
-      (hash-ref ranges obj (lambda _ null)))
+      (hash-ref ranges obj null))
+
+    (define/public (get-treeranges)
+      subs)
 
     (define/public (all-ranges)
-      sorted-ranges)
+      (force sorted-ranges))
 
     (define/public (get-identifier-list)
       identifier-list)
 
     (define sorted-ranges
+      (delay
         (sort 
          (apply append 
                 (hash-map
@@ -149,5 +180,7 @@
                    (map (lambda (v) (make-range k (car v) (cdr v))) vs))))
          (lambda (x y)
            (>= (- (range-end x) (range-start x))
-             (- (range-end y) (range-start y))))))))
+               (- (range-end y) (range-start y)))))))
+    ))
+
   

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

@@ -11,9 +11,13 @@
     [(with-unlock text . body)
      (let* ([t text]
             [locked? (send t is-locked?)])
-       (send t lock #f)
+       (send* t
+         (lock #f)
+         (begin-edit-sequence #f))
        (begin0 (let () . body)
-               (send t lock locked?)))]))
+         (send* t
+           (end-edit-sequence)
+           (lock locked?))))]))
 
 ;; make-text-port : text (-> number) -> port
 ;; builds a port from a text object.