#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)))) ;; add-check : panel symbol string (boolean -> any) (any -> boolean) -> void ;; adds a check box preference to `main'. (define (add-check main pref title [bool->pref values] [pref->bool values]) (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)))) (void))) (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) (add-check scheme-panel 'framework:highlight-parens (string-constant highlight-parens) values values) (add-check scheme-panel 'framework:fixup-parens (string-constant fixup-close-parens) values values) (add-check scheme-panel 'framework:fixup-open-parens (string-constant fixup-open-brackets) values values) (add-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 editor-general-prefs-panel-label)) (λ (editor-panel) (add-check editor-panel 'framework:delete-forward? (string-constant map-delete-to-backspace) not not) (add-check editor-panel 'framework:auto-set-wrap? (string-constant wrap-words-in-editor-buffers)) (add-check editor-panel 'framework:menu-bindings (string-constant enable-keybindings-in-menus)) (when (memq (system-type) '(macosx)) (add-check editor-panel 'framework:alt-as-meta (string-constant alt-as-meta)) (add-check editor-panel 'framework:special-meta-key (string-constant command-as-meta))) (add-check editor-panel 'framework:coloring-active (string-constant online-coloring-active)) (add-check editor-panel 'framework:anchored-search (string-constant find-anchor-based)) (add-check editor-panel 'framework:do-paste-normalization (string-constant normalize-string-preference)) (add-check editor-panel 'framework:overwrite-mode-keybindings (string-constant enable-overwrite-mode-keybindings)) (add-check editor-panel 'framework:automatic-parens (string-constant enable-automatic-parens)) (when (eq? (system-type) 'windows) (add-check editor-panel 'framework:always-use-platform-specific-linefeed-convention (string-constant always-use-platform-specific-linefeed-convention))) (add-check editor-panel 'framework:line-spacing-add-gap? (string-constant add-spacing-between-lines)) (add-number editor-panel 'framework:column-guide-width (string-constant maximum-char-width-guide-pref-check-box) (λ (n) (and (exact-integer? n) (>= n 2)))) (editor-panel-procs editor-panel))))]) (add-editor-checkbox-panel))) (define (add-number editor-panel pref-name label good-val?) (define hp (new horizontal-panel% [parent editor-panel] [stretchable-height #f])) (define init-pref (preferences:get pref-name)) (define on-cb (new check-box% [parent hp] [label label] [value (car init-pref)] [callback (λ (x y) (update-pref) (update-tf-bkg) (send tf enable (send on-cb get-value)))])) (define tf (new text-field% [label #f] [parent hp] [init-value (format "~a" (cadr init-pref))] [callback (λ (x y) (update-pref) (update-tf-bkg))])) (define (update-tf-bkg) (send tf set-field-background (send the-color-database find-color (cond [(not (send on-cb get-value)) "gray"] [(good-val? (string->number (send tf get-value))) "white"] [else "yellow"])))) (define (update-pref) (define current (preferences:get pref-name)) (define candidate-num (string->number (send tf get-value))) (preferences:set pref-name (list (send on-cb get-value) (if (good-val? candidate-num) candidate-num (cadr current))))) (update-tf-bkg)) (define (add-general-checkbox-panel) (add-general-checkbox-panel/real)) (define (add-general-checkbox-panel/real) (set! add-general-checkbox-panel/real void) (add-checkbox-panel (list (string-constant general-prefs-panel-label)) (λ (editor-panel) (make-recent-items-slider editor-panel) (add-check editor-panel 'framework:autosaving-on? (string-constant auto-save-files)) (add-check editor-panel 'framework:backup-files? (string-constant backup-files)) (add-check editor-panel 'framework:show-status-line (string-constant show-status-line)) ;; does this not belong here? ;; (add-check editor-panel 'drracket:show-line-numbers (string-constant show-line-numbers) (add-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one)) (add-check editor-panel 'framework:display-line-numbers (string-constant display-line-numbers)) (define print-rb (new radio-box% [label (string-constant printing-mode)] [parent editor-panel] [choices (list (string-constant print-using-platform-specific-mode) (string-constant print-to-ps) (string-constant print-to-pdf))] [callback (λ (rb evt) (preferences:set 'framework:print-output-mode (case (send print-rb get-selection) [(0) 'standard] [(1) 'postscript] [(2) 'pdf])))])) (define (update-print-rb what) (send print-rb set-selection (case what [(standard) 0] [(postscript) 1] [(pdf) 2]))) (update-print-rb (preferences:get 'framework:print-output-mode)) (preferences:add-callback 'framework:print-output-mode (λ (p v) (update-print-rb v))) (general-panel-procs editor-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) (add-check warnings-panel 'framework:verify-change-format (string-constant ask-before-changing-format)) (add-check warnings-panel 'framework:verify-exit (string-constant verify-exit)) (add-check warnings-panel 'framework:ask-about-paste-normalization (string-constant ask-about-normalizing-strings)) (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 "__"))] [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))