diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index 3fdef92cd9..6d551b1c88 100644 --- 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 index f8a47e5ac3..4f71cb542e 100644 --- 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 index 4e561b3964..a6e3e52c58 100644 --- 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 index 4c587a4c2a..c74553a515 100644 --- 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.