DrRacket now saves the font size preference on a per-monitor-configuration basis

original commit: 9a7af8c84033f3bd276a2717c3dc37f6076b6e83
2013-05-10 08:20:03 -05:00 · 2013-05-10 08:20:03 -05:00 · 61acd2eb5d
commit 61acd2eb5d
parent 66ccb3cf19
6 changed files with 185 additions and 30 deletions
--- 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?)
--- 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)]
--- 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)))
--- 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
--- 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%
--- 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))