4a2757f200
line terminators when:
a) running under windows, and
b) the file on the disk (when DrRacket first opens it)
contains all CRLF line endings.
In all other situations, the file is saved with LF terminators.
Before this commit, DrRacket would always use the platform-specific
convention, regardless of the original content of the file.
closes PR 12242
712 lines
31 KiB
Racket
712 lines
31 KiB
Racket
#lang racket/unit
|
|
|
|
#|
|
|
|
|
There are three attributes for each preference:
|
|
|
|
- default set, or not
|
|
- marshalling function set, or not
|
|
- initialization still okay, or not
|
|
|
|
the state transitions / contracts are:
|
|
|
|
get(true, _, _) -> (true, _, false)
|
|
get(false, _, _) -> error default not yet set
|
|
|
|
set is just like get.
|
|
|
|
set-default(false, _, true) -> set-default(true, _, true)
|
|
set-default(true, _, _) -> error default already set
|
|
set-default(_, _, false) -> initialization not okay anymore /* cannot happen, I think */
|
|
|
|
set-un/marshall(true, false, true) -> (true, true, true)
|
|
.. otherwise error
|
|
|
|
for all syms:
|
|
prefs-snapshot(_, _, _) -> (_, _, false)
|
|
|
|
|#
|
|
|
|
|
|
(require string-constants
|
|
mzlib/class
|
|
racket/file
|
|
"sig.rkt"
|
|
"../gui-utils.rkt"
|
|
"../preferences.rkt"
|
|
mred/mred-sig)
|
|
|
|
(import mred^
|
|
[prefix exit: framework:exit^]
|
|
[prefix panel: framework:panel^]
|
|
[prefix frame: framework:frame^])
|
|
(export framework:preferences^)
|
|
|
|
(define past-failure-ps '())
|
|
(define past-failure-vs '())
|
|
(define number-of-consecutive-failures 0)
|
|
(define stop-warning? #f)
|
|
|
|
(define get-pref-retry-result #f)
|
|
|
|
(define (get-preference/gui sym [def (λ () (error 'get-preference/gui "unknown pref ~s" sym))])
|
|
(define (try)
|
|
(get-preference sym
|
|
def
|
|
#:timeout-lock-there
|
|
(λ (filename)
|
|
(define what-to-do
|
|
(cond
|
|
[get-pref-retry-result
|
|
get-pref-retry-result]
|
|
[else
|
|
(define-values (res dont-ask-again?)
|
|
(message+check-box/custom
|
|
(string-constant error-reading-preferences)
|
|
(format (string-constant error-reading-preferences-explanation)
|
|
sym)
|
|
(string-constant dont-ask-again-until-drracket-restarted) ;; check label
|
|
(string-constant try-again)
|
|
(string-constant give-up-and-use-the-default)
|
|
#f
|
|
#f
|
|
'(caution default=1)
|
|
1)) ;; cannot return #f here or get-pref-retry-result may get set wrong
|
|
(when dont-ask-again?
|
|
(set! get-pref-retry-result res))
|
|
res]))
|
|
(case what-to-do
|
|
[(1) (try)]
|
|
[(2) (def)]))))
|
|
(try))
|
|
|
|
|
|
(define put-pref-retry-result #f)
|
|
|
|
(define (put-preferences/gui new-ps new-vs)
|
|
;; NOTE: old ones must come first in the list,
|
|
;; or else multiple sets to the same preference
|
|
;; will save old values, instead of new ones.
|
|
(define ps (begin0 (append past-failure-ps new-ps)
|
|
(set! past-failure-ps '())))
|
|
(define vs (begin0 (append past-failure-vs new-vs)
|
|
(set! past-failure-vs '())))
|
|
|
|
(define failed #f)
|
|
(define (record-actual-failure)
|
|
(set! number-of-consecutive-failures (+ number-of-consecutive-failures 1))
|
|
(set! past-failure-ps ps)
|
|
(set! past-failure-vs vs)
|
|
(set! failed #t))
|
|
(define (fail-func path)
|
|
(cond
|
|
[(= number-of-consecutive-failures 3)
|
|
(set! number-of-consecutive-failures 0)
|
|
(define the-mode (preferences-lock-file-mode))
|
|
(define mb-ans
|
|
(case the-mode
|
|
[(file-lock)
|
|
(define-values (checked? res)
|
|
(if put-pref-retry-result
|
|
(values #t 'ok)
|
|
(message+check-box
|
|
(string-constant error-saving-preferences-title)
|
|
(format (string-constant prefs-file-locked-nothing-doing)
|
|
path)
|
|
(string-constant dont-notify-again-until-drracket-restarted))))
|
|
(when checked?
|
|
(set! put-pref-retry-result #t))
|
|
2]
|
|
[(exists)
|
|
(message-box/custom
|
|
(string-constant error-saving-preferences-title)
|
|
(format (string-constant prefs-file-locked)
|
|
(path->string path))
|
|
(string-constant steal-the-lock-and-retry)
|
|
(string-constant cancel)
|
|
#f
|
|
#f ;;parent
|
|
'(default=2 caution))]
|
|
[else (error 'preferences.rkt "preferences-lock-file-mode returned unknown mode ~s\n" the-mode)]))
|
|
(case mb-ans
|
|
[(2 #f) (record-actual-failure)]
|
|
[(1)
|
|
(let ([delete-failed #f])
|
|
(with-handlers ((exn:fail:filesystem? (λ (x) (set! delete-failed x))))
|
|
(delete-file path))
|
|
(cond
|
|
[delete-failed
|
|
(record-actual-failure)
|
|
(message-box
|
|
(string-constant error-saving-preferences-title)
|
|
(exn-message delete-failed))]
|
|
[else
|
|
(put-preferences ps vs second-fail-func)]))])]
|
|
[else
|
|
(record-actual-failure)]))
|
|
(define (second-fail-func path)
|
|
(record-actual-failure)
|
|
(message-box
|
|
(string-constant error-saving-preferences-title)
|
|
(format (string-constant prefs-file-still-locked)
|
|
(path->string path))
|
|
#f
|
|
'(stop ok)))
|
|
|
|
(with-handlers ((exn:fail?
|
|
(λ (exn)
|
|
(log-warning (format "preferences: failed to save ~a prefs:\n ~a"
|
|
ps
|
|
(exn-message exn))))))
|
|
(begin0
|
|
(put-preferences ps vs fail-func)
|
|
(unless failed
|
|
(set! number-of-consecutive-failures 0)))))
|
|
|
|
;; ppanel-tree =
|
|
;; (union (make-ppanel-leaf string (union #f panel) (panel -> panel))
|
|
;; (make-ppanel-interior string (union #f panel) (listof panel-tree)))
|
|
(define-struct ppanel (name panel))
|
|
(define-struct (ppanel-leaf ppanel) (maker))
|
|
(define-struct (ppanel-interior ppanel) (children) #:mutable)
|
|
|
|
;; ppanels : (listof ppanel-tree)
|
|
(define ppanels null)
|
|
|
|
(define preferences-dialog #f)
|
|
|
|
(define (add-panel title make-panel)
|
|
(when preferences-dialog
|
|
(error 'add-panel "preferences dialog already open, cannot add new panels"))
|
|
(let ([titles (if (string? title)
|
|
(list title)
|
|
title)])
|
|
(add-to-existing-children
|
|
titles
|
|
make-panel
|
|
(λ (new-ppanels) (set! ppanels new-ppanels)))))
|
|
|
|
;; add-to-existing-children : (listof string) (panel -> panel) (ppanel -> void)
|
|
;; adds the child specified by the path in-titles to the tree.
|
|
(define (add-to-existing-children in-titles make-panel banger)
|
|
(let loop ([children ppanels]
|
|
[title (car in-titles)]
|
|
[titles (cdr in-titles)]
|
|
[banger banger])
|
|
(cond
|
|
[(null? children)
|
|
(banger (list (build-new-subtree (cons title titles) make-panel)))]
|
|
[else
|
|
(let ([child (car children)])
|
|
(if (string=? (ppanel-name child) title)
|
|
(cond
|
|
[(null? titles)
|
|
(error 'add-child "child already exists with this path: ~e" in-titles)]
|
|
[(ppanel-leaf? child)
|
|
(error 'add-child "new child's path conflicts with existing path: ~e" in-titles)]
|
|
[else
|
|
(loop
|
|
(ppanel-interior-children child)
|
|
(car titles)
|
|
(cdr titles)
|
|
(λ (children)
|
|
(set-ppanel-interior-children!
|
|
child
|
|
children)))])
|
|
(loop
|
|
(cdr children)
|
|
title
|
|
titles
|
|
(λ (children)
|
|
(banger (cons child children))))))])))
|
|
|
|
;; build-new-subtree : (cons string (listof string)) (panel -> panel) -> ppanel
|
|
(define (build-new-subtree titles make-panel)
|
|
(let loop ([title (car titles)]
|
|
[titles (cdr titles)])
|
|
(cond
|
|
[(null? titles) (make-ppanel-leaf title #f make-panel)]
|
|
[else
|
|
(make-ppanel-interior
|
|
title
|
|
#f
|
|
(list (loop (car titles) (cdr titles))))])))
|
|
|
|
|
|
(define (hide-dialog)
|
|
(when preferences-dialog
|
|
(send preferences-dialog close)))
|
|
|
|
(define (show-dialog)
|
|
(if preferences-dialog
|
|
(send preferences-dialog show #t)
|
|
(set! preferences-dialog
|
|
(make-preferences-dialog))))
|
|
|
|
(define (add-can-close-dialog-callback cb)
|
|
(set! can-close-dialog-callbacks
|
|
(cons cb can-close-dialog-callbacks)))
|
|
|
|
(define (add-on-close-dialog-callback cb)
|
|
(set! on-close-dialog-callbacks
|
|
(cons cb on-close-dialog-callbacks)))
|
|
|
|
(define on-close-dialog-callbacks null)
|
|
|
|
(define can-close-dialog-callbacks null)
|
|
|
|
(define (make-preferences-dialog)
|
|
(letrec ([stashed-prefs (preferences:get-prefs-snapshot)]
|
|
[cancelled? #f]
|
|
[frame-stashed-prefs%
|
|
(class frame:basic%
|
|
(inherit close)
|
|
(define/override (on-subwindow-char receiver event)
|
|
(cond
|
|
[(eq? 'escape (send event get-key-code))
|
|
(set! cancelled? #t)
|
|
(close)]
|
|
[else
|
|
(super on-subwindow-char receiver event)]))
|
|
(define/augment (on-close)
|
|
(when cancelled?
|
|
(preferences:restore-prefs-snapshot stashed-prefs)))
|
|
(define/override (show on?)
|
|
(when on?
|
|
;; reset the flag and save new prefs when the window becomes visible
|
|
(set! cancelled? #f)
|
|
(set! stashed-prefs (preferences:get-prefs-snapshot)))
|
|
(super show on?))
|
|
(super-new))]
|
|
[frame
|
|
(new frame-stashed-prefs%
|
|
[label (string-constant preferences)]
|
|
[height 200])]
|
|
[build-ppanel-tree
|
|
(λ (ppanel tab-panel single-panel)
|
|
(send tab-panel append (ppanel-name ppanel))
|
|
(cond
|
|
[(ppanel-leaf? ppanel)
|
|
((ppanel-leaf-maker ppanel) single-panel)]
|
|
[(ppanel-interior? ppanel)
|
|
(let-values ([(tab-panel single-panel) (make-tab/single-panel single-panel #t)])
|
|
(for-each
|
|
(λ (ppanel) (build-ppanel-tree ppanel tab-panel single-panel))
|
|
(ppanel-interior-children ppanel)))]))]
|
|
[make-tab/single-panel
|
|
(λ (parent inset?)
|
|
(letrec ([spacer (and inset?
|
|
(instantiate vertical-panel% ()
|
|
(parent parent)
|
|
(border 10)))]
|
|
[tab-panel (instantiate tab-panel% ()
|
|
(choices null)
|
|
(parent (if inset? spacer parent))
|
|
(callback (λ (_1 _2)
|
|
(tab-panel-callback
|
|
single-panel
|
|
tab-panel))))]
|
|
[single-panel (instantiate panel:single% ()
|
|
(parent tab-panel))])
|
|
(values tab-panel single-panel)))]
|
|
[tab-panel-callback
|
|
(λ (single-panel tab-panel)
|
|
(send single-panel active-child
|
|
(list-ref (send single-panel get-children)
|
|
(send tab-panel get-selection))))]
|
|
[panel (make-object vertical-panel% (send frame get-area-container))]
|
|
[_ (let-values ([(tab-panel single-panel) (make-tab/single-panel panel #f)])
|
|
(for-each
|
|
(λ (ppanel)
|
|
(build-ppanel-tree ppanel tab-panel single-panel))
|
|
ppanels)
|
|
(let ([single-panel-children (send single-panel get-children)])
|
|
(unless (null? single-panel-children)
|
|
(send single-panel active-child (car single-panel-children))
|
|
(send tab-panel set-selection 0)))
|
|
(send tab-panel focus))]
|
|
[bottom-panel (make-object horizontal-panel% panel)]
|
|
[ok-callback (λ args
|
|
(when (andmap (λ (f) (f))
|
|
can-close-dialog-callbacks)
|
|
(for-each
|
|
(λ (f) (f))
|
|
on-close-dialog-callbacks)
|
|
(send frame close)))]
|
|
[cancel-callback (λ ()
|
|
(set! cancelled? #t)
|
|
(send frame close))])
|
|
(new button%
|
|
[label (string-constant revert-to-defaults)]
|
|
[callback
|
|
(λ (a b)
|
|
(preferences:restore-defaults))]
|
|
[parent bottom-panel])
|
|
(new horizontal-panel% [parent bottom-panel]) ;; spacer
|
|
(gui-utils:ok/cancel-buttons
|
|
bottom-panel
|
|
ok-callback
|
|
(λ (a b) (cancel-callback))
|
|
(string-constant ok)
|
|
(string-constant undo-changes))
|
|
(make-object grow-box-spacer-pane% bottom-panel)
|
|
(send* bottom-panel
|
|
(stretchable-height #f)
|
|
(set-alignment 'right 'center))
|
|
(send frame show #t)
|
|
frame))
|
|
|
|
(define (add-to-scheme-checkbox-panel f)
|
|
(set! scheme-panel-procs
|
|
(let ([old scheme-panel-procs])
|
|
(λ (parent) (old parent) (f parent)))))
|
|
|
|
(define (add-to-editor-checkbox-panel f)
|
|
(set! editor-panel-procs
|
|
(let ([old editor-panel-procs])
|
|
(λ (parent) (old parent) (f parent)))))
|
|
|
|
(define (add-to-general-checkbox-panel f)
|
|
(set! general-panel-procs
|
|
(let ([old general-panel-procs])
|
|
(λ (parent) (old parent) (f parent)))))
|
|
|
|
(define (add-to-warnings-checkbox-panel f)
|
|
(set! warnings-panel-procs
|
|
(let ([old warnings-panel-procs])
|
|
(λ (parent) (old parent) (f parent)))))
|
|
|
|
(define scheme-panel-procs void)
|
|
(define editor-panel-procs void)
|
|
(define general-panel-procs void)
|
|
(define warnings-panel-procs void)
|
|
|
|
(define (add-checkbox-panel label proc)
|
|
(add-panel
|
|
label
|
|
(λ (parent)
|
|
(let* ([main (make-object vertical-panel% parent)])
|
|
(send main set-alignment 'left 'center)
|
|
(proc main)
|
|
main))))
|
|
|
|
;; make-check : panel symbol string (boolean -> any) (any -> boolean)
|
|
;; adds a check box preference to `main'.
|
|
(define (make-check main pref title bool->pref pref->bool)
|
|
(let* ([callback
|
|
(λ (check-box _)
|
|
(preferences:set pref (bool->pref (send check-box get-value))))]
|
|
[pref-value (preferences:get pref)]
|
|
[initial-value (pref->bool pref-value)]
|
|
[c (make-object check-box% title main callback)])
|
|
(send c set-value initial-value)
|
|
(preferences:add-callback
|
|
pref
|
|
(λ (p v)
|
|
(send c set-value (pref->bool v))))))
|
|
|
|
(define (make-recent-items-slider parent)
|
|
(let ([slider (instantiate slider% ()
|
|
(parent parent)
|
|
(label (string-constant number-of-open-recent-items))
|
|
(min-value 1)
|
|
(max-value 100)
|
|
(init-value (preferences:get 'framework:recent-max-count))
|
|
(callback (λ (slider y)
|
|
(preferences:set 'framework:recent-max-count
|
|
(send slider get-value)))))])
|
|
(preferences:add-callback
|
|
'framework:recent-max-count
|
|
(λ (p v)
|
|
(send slider set-value v)))))
|
|
|
|
(define (add-scheme-checkbox-panel)
|
|
(letrec ([add-scheme-checkbox-panel
|
|
(λ ()
|
|
(set! add-scheme-checkbox-panel void)
|
|
(add-checkbox-panel
|
|
(list
|
|
(string-constant editor-prefs-panel-label)
|
|
(string-constant scheme-prefs-panel-label))
|
|
(λ (scheme-panel)
|
|
(make-check scheme-panel
|
|
'framework:highlight-parens
|
|
(string-constant highlight-parens)
|
|
values values)
|
|
(make-check scheme-panel
|
|
'framework:fixup-parens
|
|
(string-constant fixup-close-parens)
|
|
values values)
|
|
(make-check scheme-panel
|
|
'framework:fixup-open-parens
|
|
(string-constant fixup-open-brackets)
|
|
values values)
|
|
(make-check scheme-panel
|
|
'framework:paren-match
|
|
(string-constant flash-paren-match)
|
|
values values)
|
|
(scheme-panel-procs scheme-panel))))])
|
|
(add-scheme-checkbox-panel)))
|
|
|
|
(define (add-editor-checkbox-panel)
|
|
(letrec ([add-editor-checkbox-panel
|
|
(λ ()
|
|
(set! add-editor-checkbox-panel void)
|
|
(add-checkbox-panel
|
|
(list (string-constant editor-prefs-panel-label)
|
|
(string-constant general-prefs-panel-label))
|
|
(λ (editor-panel)
|
|
(make-check editor-panel 'framework:delete-forward? (string-constant map-delete-to-backspace)
|
|
not not)
|
|
(make-check editor-panel
|
|
'framework:auto-set-wrap?
|
|
(string-constant wrap-words-in-editor-buffers)
|
|
values values)
|
|
|
|
(make-check editor-panel
|
|
'framework:menu-bindings
|
|
(string-constant enable-keybindings-in-menus)
|
|
values values)
|
|
(when (memq (system-type) '(macosx))
|
|
(make-check editor-panel
|
|
'framework:special-meta-key
|
|
(string-constant command-as-meta)
|
|
values values))
|
|
|
|
(make-check editor-panel
|
|
'framework:coloring-active
|
|
(string-constant online-coloring-active)
|
|
values values)
|
|
|
|
(make-check editor-panel
|
|
'framework:anchored-search
|
|
(string-constant find-anchor-based)
|
|
values values)
|
|
(make-check editor-panel
|
|
'framework:do-paste-normalization
|
|
(string-constant normalize-string-preference)
|
|
values values)
|
|
(make-check editor-panel
|
|
'framework:overwrite-mode-keybindings
|
|
(string-constant enable-overwrite-mode-keybindings)
|
|
values values)
|
|
(make-check editor-panel
|
|
'framework:automatic-parens
|
|
(string-constant enable-automatic-parens)
|
|
values values)
|
|
(when (eq? (system-type) 'windows)
|
|
(make-check editor-panel
|
|
'framework:always-use-platform-specific-linefeed-convention
|
|
(string-constant always-use-platform-specific-linefeed-convention)
|
|
values values))
|
|
(editor-panel-procs editor-panel))))])
|
|
(add-editor-checkbox-panel)))
|
|
|
|
(define (add-general-checkbox-panel)
|
|
(letrec ([add-general-checkbox-panel
|
|
(λ ()
|
|
(set! add-general-checkbox-panel void)
|
|
(add-checkbox-panel
|
|
(list (string-constant general-prefs-panel-label))
|
|
(λ (editor-panel)
|
|
(make-recent-items-slider editor-panel)
|
|
(make-check editor-panel
|
|
'framework:autosaving-on?
|
|
(string-constant auto-save-files)
|
|
values values)
|
|
(make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values)
|
|
(make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values)
|
|
;; does this not belong here?
|
|
;; (make-check editor-panel 'drracket:show-line-numbers (string-constant show-line-numbers)
|
|
(make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values)
|
|
(make-check editor-panel
|
|
'framework:display-line-numbers
|
|
(string-constant display-line-numbers)
|
|
values values)
|
|
(unless (eq? (system-type) 'unix)
|
|
(make-check editor-panel
|
|
'framework:print-output-mode
|
|
(string-constant automatically-to-ps)
|
|
(λ (b)
|
|
(if b 'postscript 'standard))
|
|
(λ (n) (eq? 'postscript n))))
|
|
(general-panel-procs editor-panel))))])
|
|
(add-general-checkbox-panel)))
|
|
|
|
(define (add-warnings-checkbox-panel)
|
|
(letrec ([add-warnings-checkbox-panel
|
|
(λ ()
|
|
(set! add-warnings-checkbox-panel void)
|
|
(add-checkbox-panel
|
|
(string-constant warnings-prefs-panel-label)
|
|
(λ (warnings-panel)
|
|
(make-check warnings-panel
|
|
'framework:verify-change-format
|
|
(string-constant ask-before-changing-format)
|
|
values values)
|
|
(make-check warnings-panel
|
|
'framework:verify-exit
|
|
(string-constant verify-exit)
|
|
values values)
|
|
(make-check warnings-panel
|
|
'framework:ask-about-paste-normalization
|
|
(string-constant ask-about-normalizing-strings)
|
|
values values)
|
|
(warnings-panel-procs warnings-panel))))])
|
|
(add-warnings-checkbox-panel)))
|
|
|
|
(define (local-add-font-panel)
|
|
(let* ([font-families-name/const
|
|
(list (list "Default" 'default)
|
|
(list "Decorative" 'decorative)
|
|
(list "Modern" 'modern)
|
|
(list "Roman" 'roman)
|
|
(list "Script" 'script)
|
|
(list "Swiss" 'swiss))]
|
|
|
|
[font-families (map car font-families-name/const)]
|
|
|
|
[font-size-entry "defaultFontSize"]
|
|
[font-default-string "Default Value"]
|
|
[font-default-size (case (system-type)
|
|
[(windows) 10]
|
|
[(macosx) 13]
|
|
[else 12])]
|
|
[font-section "mred"]
|
|
[build-font-entry (λ (x) (string-append "Screen" x "__"))]
|
|
[font-file (find-graphical-system-path 'setup-file)]
|
|
[build-font-preference-symbol
|
|
(λ (family)
|
|
(string->symbol (string-append "framework:" family)))]
|
|
|
|
[set-default
|
|
(λ (build-font-entry default pred)
|
|
(λ (family)
|
|
(let ([name (build-font-preference-symbol family)]
|
|
[font-entry (build-font-entry family)])
|
|
(preferences:set-default
|
|
name
|
|
default
|
|
(cond
|
|
[(string? default) string?]
|
|
[(number? default) number?]
|
|
[else (error 'internal-error.set-default "unrecognized default: ~a\n" default)])))))])
|
|
|
|
(for-each (set-default build-font-entry font-default-string string?)
|
|
font-families)
|
|
((set-default (λ (x) x)
|
|
font-default-size
|
|
number?)
|
|
font-size-entry)
|
|
(add-panel
|
|
(string-constant default-fonts)
|
|
(λ (parent)
|
|
(letrec ([font-size-pref-sym (build-font-preference-symbol font-size-entry)]
|
|
[ex-string (string-constant font-example-string)]
|
|
[main (make-object vertical-panel% parent)]
|
|
[fonts (cons font-default-string (get-face-list))]
|
|
[make-family-panel
|
|
(λ (name)
|
|
(let* ([pref-sym (build-font-preference-symbol name)]
|
|
[family-const-pair (assoc name font-families-name/const)]
|
|
|
|
[edit (make-object text%)]
|
|
[_ (send edit insert ex-string)]
|
|
[set-edit-font
|
|
(λ (size)
|
|
(let ([delta (make-object style-delta% 'change-size size)]
|
|
[face (preferences:get pref-sym)])
|
|
(if (and (string=? face font-default-string)
|
|
family-const-pair)
|
|
(send delta set-family (cadr family-const-pair))
|
|
(send delta set-delta-face (preferences:get pref-sym)))
|
|
|
|
(send edit change-style delta 0 (send edit last-position))))]
|
|
|
|
[horiz (make-object horizontal-panel% main '(border))]
|
|
[label (make-object message% name horiz)]
|
|
|
|
[message (make-object message%
|
|
(let ([b (box "")])
|
|
font-default-string)
|
|
horiz)]
|
|
[button
|
|
(make-object button%
|
|
(string-constant change-font-button-label)
|
|
horiz
|
|
(λ (button evt)
|
|
(let ([new-value
|
|
(get-choices-from-user
|
|
(string-constant fonts)
|
|
(format (string-constant choose-a-new-font)
|
|
name)
|
|
fonts)])
|
|
(when new-value
|
|
(preferences:set pref-sym (list-ref fonts (car new-value)))
|
|
(set-edit-font (preferences:get font-size-pref-sym))))))]
|
|
[canvas (make-object editor-canvas% horiz
|
|
edit
|
|
(list 'hide-hscroll
|
|
'hide-vscroll))])
|
|
(set-edit-font (preferences:get font-size-pref-sym))
|
|
(preferences:add-callback
|
|
pref-sym
|
|
(λ (p new-value)
|
|
(send horiz change-children
|
|
(λ (l)
|
|
(let ([new-message (make-object message%
|
|
new-value
|
|
horiz)])
|
|
(set! message new-message)
|
|
(update-message-sizes font-message-get-widths
|
|
font-message-user-min-sizes)
|
|
(list label
|
|
new-message
|
|
button
|
|
canvas))))))
|
|
(send canvas set-line-count 1)
|
|
(vector set-edit-font
|
|
(λ () (send message get-width))
|
|
(λ (width) (send message min-width width))
|
|
(λ () (send label get-width))
|
|
(λ (width) (send label min-width width)))))]
|
|
[set-edit-fonts/messages (map make-family-panel font-families)]
|
|
[collect (λ (n) (map (λ (x) (vector-ref x n))
|
|
set-edit-fonts/messages))]
|
|
[set-edit-fonts (collect 0)]
|
|
[font-message-get-widths (collect 1)]
|
|
[font-message-user-min-sizes (collect 2)]
|
|
[category-message-get-widths (collect 3)]
|
|
[category-message-user-min-sizes (collect 4)]
|
|
[update-message-sizes
|
|
(λ (gets sets)
|
|
(let ([width (foldl (λ (x l) (max l (x))) 0 gets)])
|
|
(for-each (λ (set) (set width)) sets)))]
|
|
[size-panel (make-object horizontal-panel% main '(border))]
|
|
[initial-font-size
|
|
(let ([b (box 0)])
|
|
font-default-size)]
|
|
[size-slider
|
|
(make-object slider%
|
|
(string-constant font-size-slider-label)
|
|
1 127
|
|
size-panel
|
|
(λ (slider evt)
|
|
(preferences:set font-size-pref-sym (send slider get-value)))
|
|
initial-font-size)])
|
|
(update-message-sizes font-message-get-widths font-message-user-min-sizes)
|
|
(update-message-sizes category-message-get-widths category-message-user-min-sizes)
|
|
(preferences:add-callback
|
|
font-size-pref-sym
|
|
(λ (p value)
|
|
(for-each (λ (f) (f value)) set-edit-fonts)
|
|
(unless (= value (send size-slider get-value))
|
|
(send size-slider set-value value))
|
|
#t))
|
|
(for-each (λ (f) (f initial-font-size)) set-edit-fonts)
|
|
(make-object message% (string-constant restart-to-see-font-changes) main)
|
|
main))))
|
|
(set! local-add-font-panel void))
|
|
|
|
(define (add-font-panel) (local-add-font-panel))
|