commit 30f9d07cc2c23921015cf3c19a1c1f31e002b2ca
parent 33f98ad0036b899c6c7a6cd7edb37f6ee0235581
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 13 Jan 2009 00:43:47 +0000
macro stepper: cleaned up column-width detection/resizing
svn: r13082
original commit: 3d3bcfe2f742a73eadb60409f3e87d6f863912ee
Diffstat:
4 files changed, 117 insertions(+), 125 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss
@@ -9,34 +9,68 @@
(provide print-syntax-to-editor
code-style)
-;; print-syntax-to-editor : syntax text controller<%> -> display<%>
-(define (print-syntax-to-editor stx text controller config)
- (new display% (syntax stx) (text text) (controller controller) (config config)))
-
;; 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 get-primary-partition)
+ (send config get-colors)
+ (send 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))
+
+;; add-clickbacks : text% range% controller<%> number -> void
+(define (add-clickbacks text range controller insertion-point)
+ (for ([range (send range all-ranges)])
+ (let ([stx (range-obj range)]
+ [start (range-start range)]
+ [end (range-end range)])
+ (send text set-clickback (+ insertion-point start) (+ insertion-point end)
+ (lambda (_1 _2 _3)
+ (send controller 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 get-syntax-font-size))
+ start end))
+
;; display%
(define display%
(class* object% (display<%>)
- (init ((stx syntax)))
(init-field text)
(init-field controller)
(init-field config)
+ (init-field range)
+ (init-field start-position)
+ (init-field end-position)
- (define start-anchor (new anchor-snip%))
- (define end-anchor (new anchor-snip%))
- (define range #f)
(define extra-styles (make-hasheq))
- ;; render-syntax : syntax -> void
- (define/public (render-syntax stx)
- (with-unlock text
- (send text delete (get-start-position) (get-end-position))
- (set! range
- (print-syntax stx text controller config
- (lambda () (get-start-position))
- (lambda () (get-end-position))))
- (apply-primary-partition-styles))
+ ;; initialize : -> void
+ (define/public (initialize)
+ (apply-primary-partition-styles)
(refresh))
;; refresh : -> void
@@ -45,7 +79,7 @@
(with-unlock text
(send* text
(begin-edit-sequence)
- (change-style unhighlight-d (get-start-position) (get-end-position)))
+ (change-style unhighlight-d start-position end-position))
(apply-extra-styles)
(let ([selected-syntax (send controller get-selected-syntax)])
(apply-secondary-partition-styles selected-syntax)
@@ -53,28 +87,14 @@
(send* text
(end-edit-sequence))))
- ;; cached-start-position : number
- (define cached-start-position #f)
+ ;; get-range : -> range<%>
+ (define/public (get-range) range)
;; get-start-position : -> number
- (define/public-final (get-start-position)
- (unless cached-start-position
- (set! cached-start-position (send text get-snip-position start-anchor)))
- cached-start-position)
+ (define/public (get-start-position) start-position)
;; get-end-position : -> number
- (define/public-final (get-end-position)
- (send text get-snip-position end-anchor))
-
- ;; relative->text-position : number -> number
- ;; FIXME: might be slow to find start every time!
- (define/public-final (relative->text-position pos)
- (+ pos (get-start-position)))
-
- ;; Styling
-
- ;; get-range : -> range<%>
- (define/public (get-range) range)
+ (define/public (get-end-position) end-position)
;; highlight-syntaxes : (list-of syntax) string -> void
(define/public (highlight-syntaxes stxs hi-color)
@@ -89,11 +109,50 @@
(add-extra-styles stx (list underline-style-delta)))
(refresh))
+ ;; add-extra-styles : syntax (listof style) -> void
(define/public (add-extra-styles stx styles)
(hash-set! extra-styles stx
(append (hash-ref extra-styles stx null)
styles)))
+ ;; Primary styles
+ ;; (Done once on initialization, never repeated)
+
+ ;; apply-primary-partition-styles : -> void
+ ;; 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 (color-style color)
+ (let ([delta (new style-delta%)])
+ (send delta set-delta-foreground color)
+ delta))
+ (define color-styles (list->vector (map color-style (send config get-colors))))
+ (define overflow-style (color-style "darkgray"))
+ (define color-partition (send controller 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 all-ranges)))
+
+ ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
+ ;; -> style-delta%
+ (define/private (primary-style stx partition color-vector overflow)
+ (let ([n (send partition get-partition stx)])
+ (cond [(< n (vector-length color-vector))
+ (vector-ref color-vector n)]
+ [else
+ overflow])))
+
+ ;; Secondary Styling
+ ;; May change in response to user actions
+
;; apply-extra-styles : -> void
;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles)
@@ -131,101 +190,35 @@
(relative->text-position (car r))
(relative->text-position (cdr r))))
- ;; Primary styles
-
- ;; apply-primary-partition-styles : -> void
- ;; 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 (color-style color)
- (let ([delta (new style-delta%)])
- (send delta set-delta-foreground color)
- delta))
- (define color-styles (list->vector (map color-style (send config get-colors))))
- (define overflow-style (color-style "darkgray"))
- (define color-partition (send controller get-primary-partition))
- (define offset (get-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 all-ranges)))
-
- ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
- ;; -> style-delta%
- (define/private (primary-style stx partition color-vector overflow)
- (let ([n (send partition get-partition stx)])
- (cond [(< n (vector-length color-vector))
- (vector-ref color-vector n)]
- [else
- overflow])))
+ ;; relative->text-position : number -> number
+ (define/private (relative->text-position pos)
+ (+ pos start-position))
;; Initialize
(super-new)
- (send text insert start-anchor)
- (send text insert end-anchor)
- (render-syntax stx)
(send controller add-syntax-display this)))
-;; print-syntax : syntax text% controller config (-> number) (-> number)
-;; -> range%
-(define (print-syntax stx text controller config
- get-start-position get-end-position)
- (define primary-partition (send controller get-primary-partition))
- (define real-output-port (make-text-port text get-end-position))
- (define output-port (open-output-string))
- (define colors (send config get-colors))
- (define suffix-option (send config get-suffix-option))
- (define columns (send config get-columns))
-
- (port-count-lines! output-port)
- (let ([range (pretty-print-syntax stx output-port primary-partition
- colors suffix-option columns)])
- (write-string (get-output-string output-port) real-output-port)
- (let ([end (get-end-position)])
- ;; Pretty printer always inserts final newline; we remove it here.
- (send text delete (sub1 end) end))
- (let ([offset (get-start-position)])
- (fixup-parentheses text range offset)
- (for-each
- (lambda (range)
- (let* ([stx (range-obj range)]
- [start (range-start range)]
- [end (range-end range)])
- (send text set-clickback (+ offset start) (+ offset end)
- (lambda (_1 _2 _3)
- (send controller set-selected-syntax stx)))))
- (send range all-ranges)))
- ;; Set font to standard
- (send text change-style
- (code-style text (send config get-syntax-font-size))
- (get-start-position)
- (get-end-position))
- range))
-
-;; fixup-parentheses : text range -> void
-(define (fixup-parentheses text range offset)
+;; fixup-parentheses : string range -> void
+(define (fixup-parentheses string range)
(define (fixup r)
(let ([stx (range-obj r)]
- [start (+ offset (range-start r))]
- [end (+ offset (range-end r))])
+ [start (range-start r)]
+ [end (range-end r)])
(when (and (syntax? stx) (pair? (syntax-e stx)))
(case (syntax-property stx 'paren-shape)
((#\[)
- (replace start #\[)
- (replace (sub1 end) #\]))
+ (string-set! string start #\[)
+ (string-set! string (sub1 end) #\]))
((#\{)
- (replace start #\{)
- (replace (sub1 end) #\}))))))
- (define (replace pos char)
- (send text insert char pos (add1 pos)))
+ (string-set! string start #\{)
+ (string-set! string (sub1 end) #\}))))))
(for-each fixup (send range all-ranges)))
+(define (open-output-string/count-lines)
+ (let ([os (open-output-string)])
+ (port-count-lines! os)
+ os))
+
;; code-style : text<%> number/#f -> style<%>
(define (code-style text font-size)
(let* ([style-list (send text get-style-list)]
diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss
@@ -22,9 +22,6 @@
(define prefs-base%
(class object%
- ;; columns : number
- (field/notify columns (new notify-box% (value 60)))
-
;; suffix-option : SuffixOption
(field/notify suffix-option (new notify-box% (value 'over-limit)))
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
@@ -143,7 +143,7 @@
(for ([binder-r (send range get-ranges binder)])
(for ([id-r (send range get-ranges id)])
(add-binding-arrow start binder-r id-r definite?)))))))
- display))
+ (void)))
(define/private (add-binding-arrow start binder-r id-r definite?)
(if definite?
@@ -189,14 +189,17 @@
;; internal-add-syntax : syntax -> display
(define/private (internal-add-syntax stx)
(with-unlock -text
- (let ([display (print-syntax-to-editor stx -text controller config)])
+ (let ([display
+ (print-syntax-to-editor stx -text controller config
+ (calculate-columns)
+ (send -text last-position))])
(send* -text
(insert "\n")
;;(scroll-to-position current-position)
)
display)))
- (define/public (calculate-columns)
+ (define/private (calculate-columns)
(define style (code-style -text (send config get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss
@@ -54,7 +54,6 @@
(define/override (on-size w h)
(send config set-width w)
(send config set-height h)
- (send config set-columns (send (send widget get-view) calculate-columns))
(send widget update/preserve-view))
(define warning-panel
