diff --git a/src/scm/startup/prefs.scm b/src/scm/startup/prefs.scm index ca29cbc3a6..d0da3c2712 100644 --- a/src/scm/startup/prefs.scm +++ b/src/scm/startup/prefs.scm @@ -1,42 +1,332 @@ +;;;; Preferences... +(use-modules (ice-9 slib)) +(require 'sort) -;; Preferences... +;; (define gnc:*double-entry-restriction* +;; (gnc:make-config-var +;; "Determines how the splits in a transaction will be balanced. +;; The following values have significance: +;; +;; #f anything goes +;; +;; 'force The sum of all splits in a transaction will be +;; forced to be zero, even if this requires the +;; creation of additional splits. Note that a split +;; whose value is zero (e.g. a stock price) can exist +;; by itself. Otherwise, all splits must come in at +;; least pairs. +;; +;; 'collect splits without parents will be forced into a +;; lost & found account. (Not implemented)" +;; (lambda (var value) +;; (cond +;; ((eq? value #f) +;; (_gnc_set_force_double_entry_ 0) +;; (list value)) +;; ((eq? value 'force) +;; (_gnc_set_force_double_entry_ 1) +;; (list value)) +;; ((eq? value 'collect) +;; (gnc:warn +;; "gnc:*double-entry-restriction* -- 'collect not supported yet. " +;; "Ignoring.") +;; #f) +;; (else +;; (gnc:warn +;; "gnc:*double-entry-restriction* -- " value " not supported. Ignoring.") +;; #f))) +;; eq? +;; #f)) -(define gnc:*double-entry-restriction* - (gnc:make-config-var - "Determines how the splits in a transaction will be balanced. - The following values have significance: +;; We'd rather use a hash table for this, but until hash-for-each or +;; hash-keys is generally available, we can't... +(define gnc_:*options-dialog-entries* '()) - #f anything goes +;; This will be an alist +;; (k v) -> (section-name list-of-option-items) - 'force The sum of all splits in a transaction will be - forced to be zero, even if this requires the - creation of additional splits. Note that a split - whose value is zero (e.g. a stock price) can exist - by itself. Otherwise, all splits must come in at - least pairs. +;; For now all the setters need to be idempotent. We may call them +;; more than once per value change. This is because of the way we +;; handle cancel and apply. - 'collect splits without parents will be forced into a - lost & found account. (Not implemented)" - (lambda (var value) - (cond - ((eq? value #f) - (xaccConfigSetForceDoubleEntry 0) - (list value)) - ((eq? value 'force) - (xaccConfigSetForceDoubleEntry 1) - (list value)) - ((eq? value 'collect) - (gnc:warn - "gnc:*double-entry-restriction* -- 'collect not supported yet. " - "Ignoring.") - #f) - (else - (gnc:warn - "gnc:*double-entry-restriction* -- " value " not supported. Ignoring.") - #f))) - eq? - #f)) +(define (gnc:make-configuration-option + section + name + sort-tag + type + documentation-string + getter + setter + default-getter + generate-restore-form + ui-value-validator) + (vector section + name + sort-tag + type + documentation-string + getter + setter + default-getter + generate-restore-form + #f + ui-value-validator)) + +(define (gnc:configuration-option-section option) + (vector-ref option 0)) +(define (gnc:configuration-option-name option) + (vector-ref option 1)) +(define (gnc:configuration-option-sort-tag option) + (vector-ref option 2)) +(define (gnc:configuration-option-type option) + (vector-ref option 3)) +(define (gnc:configuration-option-documentation option) + (vector-ref option 4)) +(define (gnc:configuration-option-getter option) + (vector-ref option 5)) +(define (gnc:configuration-option-setter option) + (vector-ref option 6)) +(define (gnc:configuration-option-default-getter option) + (vector-ref option 7)) +(define (gnc:configuration-option-generate-restore-form option) + (vector-ref option 8)) + +(define (gnc:configuration-option-widget-get option) + (vector-ref option 9)) +(define (gnc:configuration-option-widget-set! option widget) + (vector-set! option 9 widget)) + +;; Validation func should return (#t value) on success, and +;; (#f "failure-message") on failure. +(define (gnc:configuration-option-ui-value-validator option) + (vector-ref option 10)) + + +(define (gnc:register-configuration-option new-item) + + (let* ((section (gnc:configuration-option-section new-item)) + (existing-entry (assoc-ref gnc_:*options-dialog-entries* section))) + (if existing-entry + (set! gnc_:*options-dialog-entries* + (assoc-set! gnc_:*options-dialog-entries* + section + (cons new-item existing-entry))) + (set! gnc_:*options-dialog-entries* + (assoc-set! gnc_:*options-dialog-entries* + section + (list new-item)))))) + +;; Cancel checkpoint actions. + +(define (gnc:options-dialog-clear-cancel-actions) #f) +(define (gnc:options-dialog-apply-cancel-actions) #f) +(define (gnc:options-dialog-add-cancel-action action) #f) + +(let ((cancel-actions '())) + (set! gnc:options-dialog-clear-cancel-actions + (lambda () (set! cancel-actions '()))) + (set! gnc:options-dialog-apply-cancel-actions + (lambda () + (for-each (lambda (a) (a)) (reverse cancel-actions)))) + (set! gnc:options-dialog-add-cancel-action + (lambda (action) + (set! cancel-actions (cons action cancel-actions))))) + +(define (gnc:options-dialog-cancel-clicked) + (gnc:options-dialog-apply-cancel-actions)) + +;; Apply checkpoint actions. + +(define (gnc:options-dialog-clear-ok-actions) #f) +(define (gnc:options-dialog-get-ok-actions) #f) +(define (gnc:options-dialog-add-ok-action action) #f) + +(let ((ok-actions '())) + (set! gnc:options-dialog-clear-ok-actions + (lambda () (set! ok-actions '()))) + (set! gnc:options-dialog-get-ok-actions + (lambda () + ok-actions)) + (set! gnc:options-dialog-add-ok-action + (lambda (action) + (set! ok-actions (cons action ok-actions))))) + +(define (gnc:options-dialog-ok-clicked) + (let ((actions (reverse (gnc:options-dialog-get-ok-actions)))) + (let execute-actions ((remainder actions)) + (cond ((null? remainder) #t) + (else (if ((car remainder)) + (execute-actions (cdr remainder)) + #f)))))) + +(define (gnc_warning_dialog message) + (gnc:warn message) + (gnc:warn "This function needs to be replaced by a real UI.")) + +(define (gnc:options-dialog-item-apply-new-ui-value item) + (let ((current-ui-value (_gnc_options_dialog_item_get_ui_value_ item)) + (validation-func (gnc:configuration-option-ui-value-validator item)) + (verification-result #f)) + + (if validation-func + (set! verification-result (validation-func current-ui-value)) + (set! verification-result (list current-ui-value))) + + (if (car verification-result) + (begin + ;; if it's OK then update item, refresh UI, and return #t + ((gnc:configuration-option-setter item) (cadr verification-result)) + (_gnc_options_dialog_item_refresh_ui_ item) + #t) + (begin + (gnc_warning_dialog (cadr verification-result)) + #f)))) + +(define (gnc_:insert-options-dialog-item gnome-widget configuration-item) + + ;; Set things up so that we can revert to the current value if the + ;; user hits cancel (elegant method, no?). + (gnc:options-dialog-add-cancel-action + (let ((current-value ((gnc:configuration-option-getter configuration-item))) + (setter (gnc:configuration-option-setter configuration-item))) + (lambda () + (setter current-value)))) + + (gnc:options-dialog-add-ok-action + (lambda () + (gnc:options-dialog-item-apply-new-ui-value configuration-item))) + + (_gnc_options_dialog_add_item_ gnome-widget configuration-item)) + + +(define (gnc_:build-options-dialog-page section-info) + ;; section-info is a pair (section-name . list-of-options) + (let ((gtk-page-widget (_gnc_options_dialog_add_page_ (car section-info))) + (sorted-section-items + (sort (cdr section-info) + (lambda (x y) + (string