commit 0db44906c80f4a835d75172878e05961478abc44
parent 225ea79377e547dc85f1058be5db0438d8b8ac0a
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 22 Oct 2009 06:00:15 +0000
macro-stepper: syntax display speedups (?)
switched from style-deltas to styles
tree traversal of ranges, avoid idempotent style changes
svn: r16407
original commit: 07321ca17cea1a6f347bba7bff0018a37d16a9d4
Diffstat:
4 files changed, 135 insertions(+), 58 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss
@@ -1,44 +1,76 @@
#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)
- (define output-port (open-output-string/count-lines))
- (define range
- (pretty-print-syntax stx output-port
- (send: controller controller<%> get-primary-partition)
- (send: config config<%> get-colors)
- (send: config config<%> get-suffix-option)
- columns))
- (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
- (new display%
- (text text)
- (controller controller)
- (config config)
- (range range)
- (start-position insertion-point)
- (end-position (+ insertion-point output-length)))])
- (send text begin-edit-sequence)
- (send text insert output-length output-string insertion-point)
- (add-clickbacks text range controller insertion-point)
- (set-standard-font text config insertion-point (+ insertion-point output-length))
- (send display initialize)
- (send text end-edit-sequence)
- display))
+ (begin-with-definitions
+ (define **entry (now))
+ (define output-port (open-output-string/count-lines))
+ (define range
+ (pretty-print-syntax stx output-port
+ (send: controller controller<%> get-primary-partition)
+ (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)
+ (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))))
+ (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)
+ (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
(define (add-clickbacks text range controller insertion-point)
@@ -51,11 +83,8 @@
(send: controller selection-manager<%>
set-selected-syntax stx))))))
-;; set-standard-font : text% config number number -> void
-(define (set-standard-font text config start end)
- (send text change-style
- (code-style text (send: config config<%> get-syntax-font-size))
- start end))
+(define (standard-font text config)
+ (code-style text (send: config config<%> get-syntax-font-size)))
;; 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
- (lambda (range)
- (let ([stx (range-obj range)]
- [start (range-start range)]
- [end (range-end range)])
- (send text change-style
- (primary-style stx color-partition color-styles overflow-style)
- (+ offset start)
- (+ offset end))))
- (send: range range<%> all-ranges)))
+ ;; Optimization: don't call change-style when new style = old style
+ (let tr*loop ([trs (send: range range<%> get-treeranges)] [old-style #f])
+ (for ([tr trs])
+ (define stx (treerange-obj tr))
+ (define start (treerange-start tr))
+ (define end (treerange-end tr))
+ (define subs (treerange-subs tr))
+ (define new-style
+ (primary-style stx color-partition color-styles overflow-style))
+ (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%
diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/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<%> ()
diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/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,24 +156,31 @@
(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
- (sort
- (apply append
- (hash-map
- ranges
- (lambda (k vs)
- (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))))))))
-
+ (delay
+ (sort
+ (apply append
+ (hash-map
+ ranges
+ (lambda (k vs)
+ (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)))))))
+ ))
+
+
diff --git a/collects/macro-debugger/syntax-browser/util.ss b/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.
