diff --git a/collects/drracket/private/font.rkt b/collects/drracket/private/font.rkt index 0fa51f581a..21c4413476 100644 --- a/collects/drracket/private/font.rkt +++ b/collects/drracket/private/font.rkt @@ -30,10 +30,8 @@ (parent options-panel) (label (string-constant font-size)))) (define (adjust-font-size f) - (preferences:set - 'framework:standard-style-list:font-size - (f (preferences:get - 'framework:standard-style-list:font-size)))) + (editor:set-current-preferred-font-size + (f (editor:get-current-preferred-font-size)))) (define size-slider (new slider% (label #f) @@ -46,7 +44,7 @@ (λ (old-size) (send size get-value))))) (init-value - (preferences:get 'framework:standard-style-list:font-size)))) + (editor:get-current-preferred-font-size)))) (define size-hp (new horizontal-pane% (parent size-panel))) (define (mk-size-button label chng) (new button% @@ -196,7 +194,9 @@ (send text end-edit-sequence)) (preferences:add-callback 'framework:standard-style-list:font-size - (λ (p v) (send size-slider set-value v))) + (λ (p v) (send size-slider set-value + (editor:font-size-pref->current-font-size + v)))) (preferences:add-callback drracket:language-configuration:settings-preferences-symbol (λ (p v) diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index 62a543572d..253f4ba33f 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -649,6 +649,8 @@ (drracket:module-language:initialize-prefs-panel) +(editor:set-change-font-size-when-monitors-change? #t) + (let* ([find-frame (λ (item) (let loop ([item item]) @@ -751,6 +753,11 @@ ;; that is uninitialized (phase level 0); ;; reference appears in module: ...) +;; we also do this as a low-priority callback since work above +;; (specifically the call to editor:set-change-font-size-when-monitors-change?) +;; may have triggered other low-priority callbacks that we +;; want to complete before we open up that first DrRacket window. + (queue-callback (λ () @@ -786,4 +793,5 @@ (make-basic)) (when (and (preferences:get 'drracket:open-in-tabs) (not (null? no-dups))) - (handler:edit-file (car no-dups)))))) + (handler:edit-file (car no-dups))))) + #f) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index a892a7a13b..f95d905ce6 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -1721,7 +1721,7 @@ (set! msgs _msgs) (set! err? _err?) (set! copy-msg _copy-msg) - (set-the-height/dc-font (preferences:get 'framework:standard-style-list:font-size)) + (set-the-height/dc-font (editor:get-current-preferred-font-size)) (refresh)) (define/override (on-event evt) (cond @@ -1756,7 +1756,8 @@ ;; need object to hold onto this function, so this is ;; intentionally a private field, not a method - (define (font-size-changed-callback _ new-size) + (define (font-size-changed-callback _ new-prefs) + (define new-size (editor:font-size-pref->current-font-size new-prefs)) (set-the-height/dc-font new-size) (refresh)) (preferences:add-callback @@ -1784,7 +1785,7 @@ (inherit min-height) (set-the-height/dc-font - (preferences:get 'framework:standard-style-list:font-size)))) + (editor:get-current-preferred-font-size)))) (define yellow-message% (class canvas% diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index c327555453..ca864ff8aa 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -3417,17 +3417,15 @@ module browser threading seems wrong. (let () (define (font-adjust adj label key shortcut) (define (adj-font _1 _2) - (preferences:set - 'framework:standard-style-list:font-size - (adj (preferences:get - 'framework:standard-style-list:font-size)))) + (editor:set-current-preferred-font-size + (adj + (editor:get-current-preferred-font-size)))) (define (on-demand item) (define lab (format label (adj - (preferences:get - 'framework:standard-style-list:font-size)))) + (editor:get-current-preferred-font-size)))) (send item set-label lab)) (define item (new menu:can-restore-menu-item% diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index 04526ccfb4..6cb6d7e277 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -1510,6 +1510,85 @@ (keymap) @{Initializes @racket[keymap] with Racket-mode keybindings.}) + (proc-doc/names + editor:set-current-preferred-font-size + (-> exact-nonnegative-integer? void?) + (new-size) + @{Sets the font preference for the current monitor configuration to + @racket[new-size]. + + See also @racket[editor:get-current-preferred-font-size] + and @racket[editor:font-size-pref->current-font-size].}) + + (proc-doc + editor:get-current-preferred-font-size + (-> exact-nonnegative-integer?) + @{Gets the current setting for the font size preference. Calls + @racket[editor:font-size-pref->current-font-size] with the + current preference setting. + + See also @racket[editor:set-current-preferred-font-size] and + @racket[editor:get-change-font-size-when-monitors-change?]. + }) + + (proc-doc/names + editor:font-size-pref->current-font-size + (-> (vector/c + ;; font sizes for specific monitor configurations + (hash/c + ;; a particular monitor configuration: the widths and heights + (non-empty-listof (list/c exact-nonnegative-integer? + exact-nonnegative-integer?)) + ;; the font size for that configuration + exact-nonnegative-integer? + #:flat? #t) + + ;; default font size, when none of the configs above apply + exact-nonnegative-integer? + #:flat? #t) + exact-nonnegative-integer?) + (font-preference) + @{Determines the current monitor configuration and uses that to pick + one of the sizes from its argument. The argument is expected + to come from the preference value of @racket['framework:standard-style-list:font-size]. + + Except if @racket[editor:get-change-font-size-when-monitors-change?] returns + @racket[#f], in which case the current monitor configuration is not considered + and the last-set size (the second position in the vector) is always returned. + + As background, the font size + preference is actually saved on a per-monitor configuration basis; specifically + the preference value (using the same contract as the argument of this function) + contains a table mapping a list of monitor sizes (but not their + positions) obtained by @racket[get-display-size] to the preferred font size + (plus a default size used for new configurations). + + See also @racket[editor:get-current-preferred-font-size], + @racket[editor:get-current-preferred-font-size], and + @racket[editor:get-change-font-size-when-monitors-change?].}) + + (proc-doc/names + editor:get-change-font-size-when-monitors-change? + (-> boolean?) + () + @{Returns @racket[#t] when the framework will automatically + adjust the current font size in the @racket["Standard"] + style of the result of @racket[editor:get-standard-style-list] + based on the monitor configuration. + + Defaults to @racket[#f] + + See also @racket[editor:set-change-font-size-when-monitors-change?]; + @racket[editor:font-size-pref->current-font-size].}) + + (proc-doc/names + editor:set-change-font-size-when-monitors-change? + (-> boolean? void?) + (b?) + @{Controls the result of @racket[editor:get-change-font-size-when-monitors-change?]. + + See also @racket[editor:get-change-font-size-when-monitors-change?].}) + (proc-doc/names editor:set-default-font-color (-> (is-a?/c color%) void?) diff --git a/collects/framework/private/editor.rkt b/collects/framework/private/editor.rkt index a4b07cd1a8..5605b10168 100644 --- a/collects/framework/private/editor.rkt +++ b/collects/framework/private/editor.rkt @@ -1,4 +1,4 @@ -#lang scheme/unit +#lang racket/unit (require mzlib/class string-constants @@ -360,35 +360,35 @@ delta)))) (define (set-default-font-color color) - (let* ([scheme-standard (send standard-style-list find-named-style default-color-style-name)] - [scheme-delta (make-object style-delta%)]) - (send scheme-standard get-delta scheme-delta) - (send scheme-delta set-delta-foreground color) - (send scheme-standard set-delta scheme-delta))) + (let* ([the-standard (send standard-style-list find-named-style default-color-style-name)] + [the-delta (make-object style-delta%)]) + (send the-standard get-delta the-delta) + (send the-delta set-delta-foreground color) + (send the-standard set-delta the-delta))) (define (set-font-size size) (update-standard-style - (λ (scheme-delta) - (send scheme-delta set-size-mult 0) - (send scheme-delta set-size-add size)))) + (λ (the-delta) + (send the-delta set-size-mult 0) + (send the-delta set-size-add size)))) (define (set-font-name name) (update-standard-style - (λ (scheme-delta) - (send scheme-delta set-delta-face name) - (send scheme-delta set-family 'modern)))) + (λ (the-delta) + (send the-delta set-delta-face name) + (send the-delta set-family 'modern)))) (define (set-font-smoothing sym) (update-standard-style - (λ (scheme-delta) - (send scheme-delta set-smoothing-on sym)))) + (λ (the-delta) + (send the-delta set-smoothing-on sym)))) (define (update-standard-style cng-delta) - (let* ([scheme-standard (send standard-style-list find-named-style "Standard")] - [scheme-delta (make-object style-delta%)]) - (send scheme-standard get-delta scheme-delta) - (cng-delta scheme-delta) - (send scheme-standard set-delta scheme-delta))) + (let* ([the-standard (send standard-style-list find-named-style "Standard")] + [the-delta (make-object style-delta%)]) + (send the-standard get-delta the-delta) + (cng-delta the-delta) + (send the-standard set-delta the-delta))) (define standard-style-list<%> (interface (editor<%>) @@ -396,7 +396,7 @@ (define standard-style-list-mixin (mixin (editor<%>) (standard-style-list<%>) - (super-instantiate ()) + (super-new) (inherit set-style-list set-load-overwrites-styles) (set-style-list standard-style-list) (set-load-overwrites-styles #f))) @@ -421,16 +421,62 @@ (define set-font-size-callback-size #f) (define (set-standard-style-list-pref-callbacks) - (set-font-size (preferences:get 'framework:standard-style-list:font-size)) + (set-font-size (get-current-preferred-font-size)) (set-font-name (preferences:get 'framework:standard-style-list:font-name)) (set-font-smoothing (preferences:get 'framework:standard-style-list:smoothing)) - (preferences:add-callback 'framework:standard-style-list:font-size (λ (p v) (set-font-size/callback v))) + (preferences:add-callback 'framework:standard-style-list:font-size + (λ (p v) + (set-font-size/callback (font-size-pref->current-font-size v)))) (preferences:add-callback 'framework:standard-style-list:font-name (λ (p v) (set-font-name v))) (preferences:add-callback 'framework:standard-style-list:smoothing (λ (p v) (set-font-smoothing v))) (unless (member (preferences:get 'framework:standard-style-list:font-name) (get-face-list)) (preferences:set 'framework:standard-style-list:font-name (get-family-builtin-face 'modern)))) + (define (get-current-preferred-font-size) + (font-size-pref->current-font-size (preferences:get 'framework:standard-style-list:font-size))) + + (define (font-size-pref->current-font-size v) + (define default-size (vector-ref v 1)) + (cond + [change-font-size-when-monitors-change? + (define monitor-sizes (get-current-monitor-sizes)) + (hash-ref (vector-ref v 0) monitor-sizes default-size)] + [else + default-size])) + + (define change-font-size-when-monitors-change? #f) + (define (get-change-font-size-when-monitors-change?) + change-font-size-when-monitors-change?) + (define (set-change-font-size-when-monitors-change? b?) + (unless (equal? change-font-size-when-monitors-change? b?) + (set! change-font-size-when-monitors-change? b?) + (set-current-preferred-font-size + (get-current-preferred-font-size)))) + + + (define (set-current-preferred-font-size new-size) + (define old-pref (preferences:get 'framework:standard-style-list:font-size)) + (define current-mons (get-current-monitor-sizes)) + (define new-monitor-sizes + (hash-set (vector-ref old-pref 0) + current-mons + new-size)) + (preferences:set 'framework:standard-style-list:font-size + (vector new-monitor-sizes new-size))) + + (define (get-current-monitor-sizes) + (let loop ([m (get-display-count)] + [sizes '()]) + (cond + [(zero? m) sizes] + [else + (define-values (w h) (get-display-size #:monitor (- m 1))) + (loop (- m 1) + (if (and w h) + (cons (list w h) sizes) + sizes))]))) + ;; set-standard-style-list-delta : string (is-a?/c style-delta<%>) -> void (define (set-standard-style-list-delta name delta) (let* ([style-list (get-standard-style-list)] diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 3393755cb2..b5f6a43b67 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -480,6 +480,9 @@ (set! latest-monitor-information new-monitor-information) (queue-callback (λ () + (when (editor:get-change-font-size-when-monitors-change?) + (editor:set-current-preferred-font-size + (editor:get-current-preferred-font-size))) (for ([frame (in-list (get-top-level-windows))]) (when (is-a? frame size-pref<%>) (send frame monitor-setup-changed))) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index 1ac7036751..2ff22aecbc 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -1,5 +1,6 @@ #lang racket/unit (require racket/class + racket/contract "sig.rkt" "../preferences.rkt" mred/mred-sig) @@ -143,11 +144,32 @@ (preferences:set-default 'framework:standard-style-list:font-size - (let* ([txt (make-object text%)] - [stl (send txt get-style-list)] - [bcs (send stl basic-style)]) - (send bcs get-size)) - (λ (x) (and (number? x) (exact? x) (integer? x) (positive? x)))) + (vector (hash) + (let* ([txt (make-object text%)] + [stl (send txt get-style-list)] + [bcs (send stl basic-style)]) + (send bcs get-size))) + (vector/c + ;; font sizes for specific monitor configurations + (hash/c + ;; a particular monitor configuration: the widths and heights + (non-empty-listof (list/c exact-nonnegative-integer? + exact-nonnegative-integer?)) + ;; the font size for that configuration + exact-nonnegative-integer? + #:flat? #t) + ;; default font size, when none of the configs above apply + exact-nonnegative-integer? + #:flat? #t)) + +(preferences:set-un/marshall + 'framework:standard-style-list:font-size + values + (λ (x) + (if (exact-nonnegative-integer? x) + ;; coerce old pref settings to new + (vector (hash) x) + x))) (preferences:set-default 'framework:standard-style-list:smoothing diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index 77f098ca65..f75d722ede 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -162,7 +162,12 @@ set-standard-style-list-delta set-default-font-color get-default-color-style-name - add-after-user-keymap)) + add-after-user-keymap + get-current-preferred-font-size + set-current-preferred-font-size + font-size-pref->current-font-size + set-change-font-size-when-monitors-change? + get-change-font-size-when-monitors-change?)) (define-signature pasteboard-class^ (basic% diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 27c9f06708..c88f06fad9 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3744,14 +3744,14 @@ designates the character that triggers autocompletion (define/private (get-mt-font) (send the-font-list find-or-create-font - (preferences:get 'framework:standard-style-list:font-size) + (editor:get-current-preferred-font-size) 'default 'italic 'normal)) (define/private (get-reg-font) (send the-font-list find-or-create-font - (preferences:get 'framework:standard-style-list:font-size) + (editor:get-current-preferred-font-size) 'default 'normal 'normal))