From b2bd5ad8aedc6c8b96185093642ea44f1fcc3f55 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 19 Jun 2003 22:51:07 +0000 Subject: [PATCH] .. original commit: 7d32fff4834107ff756e281296a24a88b8fb0d31 --- collects/framework/framework.ss | 21 +++++++ collects/framework/private/editor.ss | 84 ++++++++++++++++++++++++---- collects/framework/private/main.ss | 25 ++++++++- collects/framework/private/sig.ss | 4 +- 4 files changed, 120 insertions(+), 14 deletions(-) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index de2adff7..862bfe73 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -1293,6 +1293,27 @@ () "Returns a keymap with binding suitable for Scheme.") + (editor:set-standard-style-list-pref-callbacks + (-> any) + () + "Installs the font preference callbacks that" + "update the style list returned by" + "@flink editor:get-standard-style-list" + "based on the font preference symbols.") + + (editor:get-fixed-faces + (-> (listof string?)) + () + "Returns a list of the fixed width fonts available on this system," + "except on unix, where it returns a list of all of the fonts." + "" + "It finds the fixed width fonts by making a dummy canvas object," + "and computes the width of both `i' and `w'. If they are the same," + "the font is fixed width and if not, the font is not fixed width." + "" + "This is very expensive under X Windows, which is why the function" + "just returns all fonts.") + (editor:get-standard-style-list (-> (is-a?/c style-list%)) () diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 49782f56..f966522b 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -311,19 +311,42 @@ (super-instantiate ()))) - (define standard-style-list (make-object style-list%)) + (define standard-style-list (new style-list%)) (define (get-standard-style-list) standard-style-list) - (define delta - (let ([delta (make-object style-delta% 'change-normal)]) - (send delta set-delta 'change-family 'modern) - delta)) - (let ([style (send standard-style-list find-named-style "Standard")]) - (if style - (send style set-delta delta) - (send standard-style-list new-named-style "Standard" - (send standard-style-list find-or-create-style - (send standard-style-list find-named-style "Basic") - delta)))) + + (let ([delta (make-object style-delta% 'change-normal)]) + (send delta set-delta 'change-family 'modern) + (let ([style (send standard-style-list find-named-style "Standard")]) + (if style + (send style set-delta delta) + (send standard-style-list new-named-style "Standard" + (send standard-style-list find-or-create-style + (send standard-style-list find-named-style "Basic") + delta))))) + + (define (set-font-size size) + (update-standard-style + (lambda (scheme-delta) + (send scheme-delta set-size-mult 0) + (send scheme-delta set-size-add size)))) + + (define (set-font-name name) + (update-standard-style + (lambda (scheme-delta) + (send scheme-delta set-delta-face name) + (send scheme-delta set-family 'modern)))) + + (define (set-font-smoothing sym) + (update-standard-style + (lambda (scheme-delta) + (send scheme-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))) (define standard-style-list<%> (interface (editor<%>) @@ -336,6 +359,43 @@ (set-style-list standard-style-list) (set-load-overwrites-styles #f))) + (define (set-standard-style-list-pref-callbacks) + (set-font-size (preferences:get 'framework:standard-style-list:font-size)) + (set-font-name (preferences:get 'framework:standard-style-list:font-name)) + (set-font-smoothing (preferences:get 'framework:standard-style-list:font-smoothing)) + (preferences:add-callback 'framework:standard-style-list:font-size (lambda (p v) (set-font-size v))) + (preferences:add-callback 'framework:standard-style-list:font-name (lambda (p v) (set-font-name v))) + (preferences:add-callback 'framework:standard-style-list:font-smoothing (lambda (p v) (set-font-smoothing v))) + + (unless (member (preferences:get 'framework:standard-style-list:font-name) (get-fixed-faces)) + (preferences:set 'framework:standard-style-list:font-name (get-family-builtin-face 'modern)))) + + (define get-fixed-faces + (cond + [(eq? (system-type) 'unix) + (lambda () (get-face-list))] + [else + (let ([compute-ans + (lambda () + (let* ([canvas (make-object canvas% (make-object frame% "bogus"))] + [dc (send canvas get-dc)]) + (let loop ([faces (get-face-list)]) + (cond + [(null? faces) null] + [else (let* ([face (car faces)] + [font (make-object font% 12 face 'default 'normal 'normal #f)]) + (let*-values ([(wi _1 _2 _3) (send dc get-text-extent "i" font)] + [(ww _1 _2 _3) (send dc get-text-extent "w" font)]) + (if (and (= ww wi) + (not (zero? ww))) + (cons face (loop (cdr faces))) + (loop (cdr faces)))))]))))] + [ans #f]) + (lambda () + (unless ans + (set! ans (compute-ans))) + ans))])) + (define -keymap<%> (interface (basic<%>) get-keymaps)) (define keymap-mixin (mixin (basic<%>) (-keymap<%>) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 8c617d60..7872d770 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -15,10 +15,33 @@ [preferences : framework:preferences^] [exit : framework:exit^] [group : framework:group^] - [handler : framework:handler^]) + [handler : framework:handler^] + [editor : framework:editor^]) (application-preferences-handler (lambda () (preferences:show-dialog))) + (preferences:set-default 'framework:standard-style-list:font-name + (get-family-builtin-face 'modern) + string?) + + (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)) + (lambda (x) (and (number? x) (exact? x) (integer? x) (positive? x)))) + + (preferences:set-default + 'framework:standard-style-list:font-smoothing + (case (system-type) + [(macosx) 'partly-smoothed] + [else 'unsmoothed]) + (lambda (x) + (memq x '(unsmoothed partly-smoothed smoothed)))) + + (editor:set-standard-style-list-pref-callbacks) + (preferences:set-default 'framework:paren-match-color (let ([gray-level ;; old gray-level 192 diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 716f4a5c..51c37f26 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -262,7 +262,9 @@ file-mixin backup-autosave-mixin)) (define-signature framework:editor-fun^ - (get-standard-style-list)) + (get-standard-style-list + set-standard-style-list-pref-callbacks + get-fixed-faces)) (define-signature framework:editor^ ((open framework:editor-class^) (open framework:editor-fun^)))