suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Font size changes; prefs setting overrides default

Browse Source 
svn: r4308
This commit is contained in:
Ryan Culpepper 2006-09-11 13:47:27 +00:00
parent dbc8a7debf
commit ba5c8d5b07
2 changed files with 27 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/macro-debugger/syntax-browser/typesetter.ss
View File

@ -9,7 +9,8 @@
"interfaces.ss" "interfaces.ss"
"util.ss") "util.ss")
(provide typesetter-for-text%) (provide typesetter-for-text%
code-style)
;; typesetter-for-text% ;; typesetter-for-text%
(define typesetter-for-text% (define typesetter-for-text%
@ -34,13 +35,6 @@
(define output-port (make-text-port text end-anchor)) (define output-port (make-text-port text end-anchor))
(define base-style
(send (send text get-style-list) find-named-style "Standard")
#;(let ([sd (make-object style-delta% 'change-family 'modern)])
(when (current-syntax-font-size)
(send sd set-delta 'change-size (current-syntax-font-size)))
sd))
(define/private (get-start-position) (define/private (get-start-position)
(send text get-snip-position start-anchor)) (send text get-snip-position start-anchor))
@ -70,7 +64,7 @@
(let ([end (get-end-position)]) (let ([end (get-end-position)])
(send text delete (sub1 end) end)) (send text delete (sub1 end) end))
(send text change-style (send text change-style
base-style (code-style text)
(get-start-position) (get-start-position)
(get-end-position)) (get-end-position))
(send colorer apply-styles) (send colorer apply-styles)
@ -104,6 +98,17 @@
(send text get-snip-position end-anchor)) (send text get-snip-position end-anchor))
#t))) #t)))
;; code-style : text<%> -> style<%>
(define (code-style text)
(let* ([style-list (send text get-style-list)]
[style (send style-list find-named-style "Standard")]
[font-size (current-syntax-font-size)])
(if font-size
(send style-list find-or-create-style
style
(make-object style-delta% 'change-size font-size))
style)))
(define anchor-snip% (define anchor-snip%
(class snip% (class snip%
(define/override (copy) (define/override (copy)

16
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -36,6 +36,17 @@
(new syntax-controller% (new syntax-controller%
(properties-controller this))) (properties-controller this)))
;; FIXME: Why doesn't this work?
#;
(when (current-syntax-font-size)
(let* ([style-list (send -text get-style-list)]
[standard (send style-list find-named-style "Standard")])
(send style-list replace-named-style "Standard"
(send style-list find-or-create-style
standard
(make-object style-delta% 'change-size
(current-syntax-font-size))))))
(send -text lock #t) (send -text lock #t)
(send -split-panel set-percentages (send -split-panel set-percentages
(let ([pp (pref:props-percentage)]) (list (- 1 pp) pp))) (let ([pp (pref:props-percentage)]) (list (- 1 pp) pp)))
@ -125,9 +136,8 @@
(send new-colorer highlight-syntaxes hi-stxs hi-color))))))) (send new-colorer highlight-syntaxes hi-stxs hi-color)))))))
(define/private (calculate-columns) (define/private (calculate-columns)
(define style-list (send -text get-style-list)) (define style (code-style -text))
(define standard (send style-list find-named-style "Standard")) (define char-width (send style get-text-width (send -ecanvas get-dc)))
(define char-width (send standard get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
(sub1 (inexact->exact (floor (/ canvas-w char-width))))) (sub1 (inexact->exact (floor (/ canvas-w char-width)))))