#| 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) |# (module preferences (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") (lib "class.ss") (lib "file.ss") (lib "etc.ss") "sig.ss" "../gui-utils.ss" (lib "mred-sig.ss" "mred") (lib "pretty.ss") (lib "list.ss")) (import mred^ [prefix exn: framework:exn^] [prefix exit: framework:exit^] [prefix panel: framework:panel^] [prefix frame: framework:frame^]) (export framework:preferences^) (define old-preferences-symbol 'plt:framework-prefs) (define old-preferences (make-hash-table)) (let ([old-prefs (get-preference old-preferences-symbol (λ () '()))]) (for-each (λ (line) (hash-table-put! old-preferences (car line) (cadr line))) old-prefs)) (define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p))) ;; preferences : hash-table[sym -o> any] ;; the current values of the preferences (define preferences (make-hash-table)) ;; marshalled : hash-table[sym -o> any] ;; the values of the preferences, as read in from the disk ;; each symbol will only be mapped in one of the preferences ;; hash-table and this hash-table, but not both. (define marshalled (make-hash-table)) ;; marshall-unmarshall : sym -o> un/marshall (define marshall-unmarshall (make-hash-table)) ;; callbacks : sym -o> (listof (sym TST -> boolean)) (define callbacks (make-hash-table)) ;; defaults : hash-table[sym -o> default] (define defaults (make-hash-table)) ;; these four functions determine the state of a preference (define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref)) (define (pref-default-set? pref) (hash-table-bound? defaults pref)) (define (pref-can-init? pref) (and (not snapshot-grabbed?) (not (hash-table-bound? preferences pref)))) ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any)) (define-struct un/marshall (marshall unmarshall)) ;; type pref = (make-pref any) (define-struct pref (value)) ;; type default = (make-default any (any -> bool)) (define-struct default (value checker)) ;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void))) ;; this is used as a wrapped to deal with the problem that different procedures might be eq?. (define-struct pref-callback (cb)) ;; get : symbol -> any ;; return the current value of the preference `p' ;; exported (define (get p) (cond [(pref-default-set? p) ;; unmarshall, if required (when (hash-table-bound? marshalled p) ;; if `preferences' is already bound, that means the unmarshalled value isn't useful. (unless (hash-table-bound? preferences p) (hash-table-put! preferences p (unmarshall-pref p (hash-table-get marshalled p)))) (hash-table-remove! marshalled p)) ;; if there is no value in the preferences table, but there is one ;; in the old version preferences file, take that: (unless (hash-table-bound? preferences p) (when (hash-table-bound? old-preferences p) (hash-table-put! preferences p (unmarshall-pref p (hash-table-get old-preferences p))))) ;; clear the pref from the old table (just in case it was taking space -- we don't need it anymore) (when (hash-table-bound? old-preferences p) (hash-table-remove! old-preferences p)) ;; if it still isn't set, take the default value (unless (hash-table-bound? preferences p) (hash-table-put! preferences p (default-value (hash-table-get defaults p)))) (hash-table-get preferences p)] [(not (pref-default-set? p)) (raise-unknown-preference-error 'preferences:get "tried to get a preference but no default set for ~e" p)])) ;; set : symbol any -> void ;; updates the preference ;; exported (define (set p value) (multi-set (list p) (list value))) ;; set : symbol any -> void ;; updates the preference ;; exported (define (multi-set ps values) (for-each (λ (p value) (cond [(pref-default-set? p) (let ([default (hash-table-get defaults p)]) (unless ((default-checker default) value) (error 'preferences:set "tried to set preference ~e to ~e but it does not meet test from preferences:set-default" p value)) (check-callbacks p value) (hash-table-put! preferences p value) (void))] [(not (pref-default-set? p)) (raise-unknown-preference-error 'preferences:set "tried to set the preference ~e to ~e, but no default is set" p value)])) ps values) (put-preferences/gui (map add-pref-prefix ps) (map (λ (p value) (marshall-pref p value)) ps values)) (void)) (define (put-preferences/gui ps vs) (define (fail-func path) (let ([mb-ans (message-box/custom (string-constant error-saving-preferences-title) (format (string-constant prefs-file-locked) (path->string path)) (string-constant try-again) (string-constant cancel) #f #f ;;parent '(default=2 caution))]) (case mb-ans [(2 #f) (void)] [(1) (put-preferences ps vs second-fail-func)]))) (define (second-fail-func path) (message-box (string-constant error-saving-preferences-title) (format (string-constant prefs-file-still-locked) (path->string path)) #f '(stop ok))) (with-handlers ((exn? (λ (x) (message-box (string-constant drscheme) (format (string-constant error-saving-preferences) (exn-message x)))))) (put-preferences ps vs fail-func))) (define (raise-unknown-preference-error sym fmt . args) (raise (exn:make-unknown-preference (string->immutable-string (string-append (format "~a: " sym) (apply format fmt args))) (current-continuation-marks)))) ;; unmarshall-pref : symbol marshalled -> any ;; unmarshalls a preference read from the disk (define (unmarshall-pref p data) (let/ec k (let* ([unmarshall-fn (un/marshall-unmarshall (hash-table-get marshall-unmarshall p (λ () (k data))))] [default (hash-table-get defaults p)] [result (unmarshall-fn data)]) (if ((default-checker default) result) result (default-value default))))) ;; add-callback : sym (-> void) -> void (define add-callback (opt-lambda (p callback [weak? #f]) (let ([new-cb (make-pref-callback (if weak? (make-weak-box callback) callback))]) (hash-table-put! callbacks p (append (hash-table-get callbacks p (λ () null)) (list new-cb))) (λ () (hash-table-put! callbacks p (let loop ([callbacks (hash-table-get callbacks p (λ () null))]) (cond [(null? callbacks) null] [else (let ([callback (car callbacks)]) (cond [(eq? callback new-cb) (loop (cdr callbacks))] [else (cons (car callbacks) (loop (cdr callbacks)))]))]))))))) ;; check-callbacks : sym val -> void (define (check-callbacks p value) (let ([new-callbacks (let loop ([callbacks (hash-table-get callbacks p (λ () null))]) (cond [(null? callbacks) null] [else (let* ([callback (car callbacks)] [cb (pref-callback-cb callback)]) (cond [(weak-box? cb) (let ([v (weak-box-value cb)]) (if v (begin (v p value) (cons callback (loop (cdr callbacks)))) (loop (cdr callbacks))))] [else (cb p value) (cons callback (loop (cdr callbacks)))]))]))]) (if (null? new-callbacks) (hash-table-remove! callbacks p) (hash-table-put! callbacks p new-callbacks)))) (define (set-un/marshall p marshall unmarshall) (cond [(and (pref-default-set? p) (not (pref-un/marshall-set? p)) (pref-can-init? p)) (hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))] [(not (pref-default-set? p)) (error 'preferences:set-un/marshall "must call set-default for ~s before calling set-un/marshall for ~s" p p)] [(pref-un/marshall-set? p) (error 'preferences:set-un/marshall "already set un/marshall for ~e" p)] [(not (pref-can-init? p)) (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)])) (define (hash-table-bound? ht s) (let/ec k (hash-table-get ht s (λ () (k #f))) #t)) (define (restore-defaults) (hash-table-for-each defaults (λ (p def) (set p (default-value def))))) ;; set-default : (sym TST (TST -> boolean) -> void (define (set-default p default-value checker) (cond [(and (not (pref-default-set? p)) (pref-can-init? p)) (let ([default-okay? (checker default-value)]) (unless default-okay? (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" p checker default-okay? default-value)) (hash-table-put! defaults p (make-default default-value checker)) (let/ec k (let ([m (get-preference (add-pref-prefix p) (λ () (k (void))))]) ;; if there is no preference saved, we just don't do anything. ;; `get' notices this case. (hash-table-put! marshalled p m))))] [(not (pref-can-init? p)) (error 'preferences:set-default "tried to call set-default for preference ~e but it cannot be configured any more" p)] [(pref-default-set? p) (error 'preferences:set-default "preferences default already set for ~e" p)] [(not (pref-can-init? p)) (error 'preferences:set-default "can no longer set the default for ~e" p)])) ;; marshall-pref : symbol any -> (list symbol printable) (define (marshall-pref p value) (let/ec k (let* ([marshaller (un/marshall-marshall (hash-table-get marshall-unmarshall p (λ () (k value))))]) (marshaller value)))) (define (read-err input msg) (message-box (string-constant preferences) (let* ([max-len 150] [s1 (format "~s" input)] [ell "..."] [s2 (if (<= (string-length s1) max-len) s1 (string-append (substring s1 0 (- max-len (string-length ell))) ell))]) (string-append (string-constant error-reading-preferences) "\n" msg "\n" s2)))) (define snapshot-grabbed? #f) (define (get-prefs-snapshot) (set! snapshot-grabbed? #t) (hash-table-map defaults (λ (k v) (cons k (get k))))) (define (restore-prefs-snapshot snapshot) (multi-set (map car snapshot) (map cdr snapshot))) ;; ; ;;; ; ; ; ; ;;;; ;;; ;;;; ; ;;; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ;;;;; ;;; ; ;;;;;; ;;; ;;;; ; ; ;;; ;; 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)) ;; 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-subtree) (set! ppanels (cons new-subtree 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 (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) (λ (x) (set-ppanel-interior-children! (cons x (ppanel-interior-children child)))))]) (loop (cdr children) title titles (λ (x) (set-cdr! children (cons x (cdr 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 show #f))) (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 (get-prefs-snapshot)] [frame-stashed-prefs% (class frame:basic% (define/override (show on?) (when on? (set! stashed-prefs (get-prefs-snapshot))) (super show on?)) (super-new))] [frame (make-object frame-stashed-prefs% (string-constant preferences))] [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) (hide-dialog)))] [cancel-callback (λ (_1 _2) (hide-dialog) (restore-prefs-snapshot stashed-prefs))]) (gui-utils:ok/cancel-buttons bottom-panel ok-callback cancel-callback) (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-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 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 _) (set pref (bool->pref (send check-box get-value))))] [pref-value (get pref)] [initial-value (pref->bool pref-value)] [c (make-object check-box% title main callback)]) (send c set-value initial-value) (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 (get 'framework:recent-max-count)) (callback (λ (slider y) (set 'framework:recent-max-count (send slider get-value)))))]) (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-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:delete-forward? (string-constant map-delete-to-backspace) not not) (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values) (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) (make-check editor-panel 'framework:auto-set-wrap? (string-constant wrap-words-in-editor-buffers) values values) (make-check editor-panel 'framework:search-using-dialog? (string-constant separate-dialog-for-searching) values values) (make-check editor-panel 'framework:open-here? (string-constant reuse-existing-frames) values values) (make-check editor-panel 'framework:menu-bindings (string-constant enable-keybindings-in-menus) values values) (make-check editor-panel 'framework:coloring-active (string-constant online-coloring-active) values values) (when (memq (system-type) '(macos macosx)) (make-check editor-panel 'framework:special-option-key (string-constant option-as-meta) 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)))) (editor-panel-procs editor-panel))))]) (add-editor-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) (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)]) (set-default name default (cond [(string? default) string?] [(number? default) number?] [else (error 'internal-error.set-default "unrecognized default: ~a~n" default)])) (add-callback name (λ (p new-value) (write-resource font-section font-entry (if (and (string? new-value) (string=? font-default-string new-value)) "" new-value) font-file))))))]) (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 (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 (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 "")]) (if (and (get-resource font-section (build-font-entry name) b) (not (string=? (unbox b) ""))) (unbox b) 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 (set pref-sym (list-ref fonts (car new-value))) (set-edit-font (get font-size-pref-sym))))))] [canvas (make-object editor-canvas% horiz edit (list 'hide-hscroll 'hide-vscroll))]) (set-edit-font (get font-size-pref-sym)) (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)]) (if (get-resource font-section font-size-entry b) (unbox b) font-default-size))] [size-slider (make-object slider% (string-constant font-size-slider-label) 1 127 size-panel (λ (slider evt) (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) (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)))