;; Scheme code for supporting options for the business modules
;;
;; Created by:	Derek Atkins <derek@ihtfp.com>
;;
;; This program is free software; you can redistribute it and/or    
;; modify it under the terms of the GNU General Public License as   
;; published by the Free Software Foundation; either version 2 of   
;; the License, or (at your option) any later version.              
;;                                                                  
;; This program is distributed in the hope that it will be useful,  
;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
;; GNU General Public License for more details.                     
;;                                                                  
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation           Voice:  +1-617-542-5942
;; 51 Franklin Street, Fifth Floor    Fax:    +1-617-542-2652
;; Boston, MA  02110-1301,  USA       gnu@gnu.org


;; Internally, values are always a guid. Externally, both guids and
;; invoice pointers may be used to set the value of the option. The
;; option always returns a single invoice pointer.

(use-modules (gnucash utilities))

(define (gnc:make-invoice-option
	 section
	 name
	 sort-tag
	 documentation-string
	 default-getter
	 value-validator)

  (define (convert-to-guid item)
    (if (string? item)
        item
        (gncInvoiceReturnGUID item)))

  (define (convert-to-invoice item)
    (if (string? item)
        (gncInvoiceLookupFlip item (gnc-get-current-book))
        item))

  (let* ((option (convert-to-guid (default-getter)))
         (option-set #f)
         (getter (lambda () (convert-to-invoice
			     (if option-set
				 option
				 (default-getter)))))
         (value->string (lambda ()
                          (string-append
                           "'" (gnc:value->string (if option-set option #f)))))
         (validator
          (if (not value-validator)
              (lambda (invoice) (list #t invoice))
              (lambda (invoice)
                (value-validator (convert-to-invoice invoice))))))
    (gnc:make-option
     section name sort-tag 'invoice documentation-string getter
     (lambda (invoice) ;; setter
       (if (null? invoice) (set! invoice (default-getter)))
       (set! invoice (convert-to-invoice invoice))
       (let* ((result (validator invoice))
	      (valid (car result))
	      (value (cadr result)))
	 (if valid
	     (begin
	       (set! option (convert-to-guid value))
	       (set! option-set #t))
	     (gnc:error "Illegal invoice value set"))))
     (lambda () (convert-to-invoice (default-getter)))
     (gnc:restore-form-generator value->string)
     (lambda (b p) (qof-book-set-option b option p))
     (lambda (b p)
       (let ((v (qof-book-get-option b p)))
	 (if (and v (string? v))
	     (begin
	       (set! option v)
	       (set! option-set #t)))))
     validator
     #f #f #f #f)))

;; Internally, values are always a guid. Externally, both guids and
;; customer pointers may be used to set the value of the option. The
;; option always returns a single customer pointer.

(define (gnc:make-customer-option
	 section
	 name
	 sort-tag
	 documentation-string
	 default-getter
	 value-validator)

  (define (convert-to-guid item)
    (if (string? item)
        item
        (gncCustomerReturnGUID item)))

  (define (convert-to-customer item)
    (if (string? item)
        (gncCustomerLookupFlip item (gnc-get-current-book))
        item))
  (issue-deprecation-warning
   "gnc:make-customer-option is unused.")

  (let* ((option (convert-to-guid (default-getter)))
         (option-set #f)
         (getter (lambda () (convert-to-customer
			     (if option-set
				 option
				 (default-getter)))))
         (value->string (lambda ()
                          (string-append
                           "'" (gnc:value->string (if option-set option #f)))))
         (validator
          (if (not value-validator)
              (lambda (customer) (list #t customer))
              (lambda (customer)
                (value-validator (convert-to-customer customer))))))
    (gnc:make-option
     section name sort-tag 'customer documentation-string getter
     (lambda (customer)
       (if (null? customer) (set! customer (default-getter)))
       (set! customer (convert-to-customer customer))
       (let* ((result (validator customer))
	      (valid (car result))
	      (value (cadr result)))
	 (if valid
	     (begin
	       (set! option (convert-to-guid value))
	       (set! option-set #t))
	     (gnc:error "Illegal customer value set"))))
     (lambda () (convert-to-customer (default-getter)))
     (gnc:restore-form-generator value->string)
     (lambda (b p) (qof-book-set-option b option p))
     (lambda (b p)
       (let ((v (qof-book-get-option b p)))
	 (if (and v (string? v))
	     (begin
	       (set! option v)
	       (set! option-set #t)))))
     validator
     #f #f #f #f)))

;; Internally, values are always a guid. Externally, both guids and
;; vendor pointers may be used to set the value of the option. The
;; option always returns a single vendor pointer.

(define (gnc:make-vendor-option
	 section
	 name
	 sort-tag
	 documentation-string
	 default-getter
	 value-validator)

  (define (convert-to-guid item)
    (if (string? item)
        item
        (gncVendorReturnGUID item)))

  (define (convert-to-vendor item)
    (if (string? item)
        (gncVendorLookupFlip item (gnc-get-current-book))
        item))

  (issue-deprecation-warning
   "gnc:make-vendor-option is unused.")

  (let* ((option (convert-to-guid (default-getter)))
         (option-set #f)
         (getter (lambda () (convert-to-vendor
			     (if option-set
				 option
				 (default-getter)))))
         (value->string (lambda ()
                          (string-append
                           "'" (gnc:value->string (if option-set option #f)))))
         (validator
          (if (not value-validator)
              (lambda (vendor) (list #t vendor))
              (lambda (vendor)
                (value-validator (convert-to-vendor vendor))))))
    (gnc:make-option
     section name sort-tag 'vendor documentation-string getter
     (lambda (vendor)
       (if (null? vendor) (set! vendor (default-getter)))
       (set! vendor (convert-to-vendor vendor))
       (let* ((result (validator vendor))
	      (valid (car result))
	      (value (cadr result)))
	 (if valid
	     (begin
	       (set! option (convert-to-guid value))
	       (set! option-set #t))
	     (gnc:error "Illegal vendor value set"))))
     (lambda () (convert-to-vendor (default-getter)))
     (gnc:restore-form-generator value->string)
     (lambda (b p) (qof-book-set-option b option p))
     (lambda (b p)
       (let ((v (qof-book-get-option b p)))
	 (if (and v (string? v))
	     (begin
	       (set! option v)
	       (set! option-set #t)))))
     validator
     #f #f #f #f)))

;; Internally, values are always a guid. Externally, both guids and
;; employee pointers may be used to set the value of the option. The
;; option always returns a single employee pointer.

(define (gnc:make-employee-option
	 section
	 name
	 sort-tag
	 documentation-string
	 default-getter
	 value-validator)

  (define (convert-to-guid item)
    (if (string? item)
        item
        (gncEmployeeReturnGUID item)))

  (define (convert-to-employee item)
    (if (string? item)
        (gncEmployeeLookupFlip item (gnc-get-current-book))
        item))
  (issue-deprecation-warning
   "gnc:make-employee-option is unused.")

  (let* ((option (convert-to-guid (default-getter)))
         (option-set #f)
         (getter (lambda () (convert-to-employee
			     (if option-set
				 option
				 (default-getter)))))
         (value->string (lambda ()
                          (string-append
                           "'" (gnc:value->string (if option-set option #f)))))
         (validator
          (if (not value-validator)
              (lambda (employee) (list #t employee))
              (lambda (employee)
                (value-validator (convert-to-employee employee))))))
    (gnc:make-option
     section name sort-tag 'employee documentation-string getter
     (lambda (employee)
       (if (null? employee) (set! employee (default-getter)))
       (set! employee (convert-to-employee employee))
       (let* ((result (validator employee))
	      (valid (car result))
	      (value (cadr result)))
	 (if valid
	     (begin
	       (set! option (convert-to-guid value))
	       (set! option-set #t))
	     (gnc:error "Illegal employee value set"))))
     (lambda () (convert-to-employee (default-getter)))
     (gnc:restore-form-generator value->string)
     (lambda (b p) (qof-book-set-option b option p))
     (lambda (b p)
       (let ((v (qof-book-get-option b p)))
	 (if (and v (string? v))
	     (begin
	       (set! option v)
	       (set! option-set #t)))))
     validator
     #f #f #f #f)))

;; Internally, values are always a type/guid pair. Externally, both
;; type/guid pairs and owner pointers may be used to set the value of
;; the option. The option always returns a single owner pointer.

(define (gnc:make-owner-option
	 section
	 name
	 sort-tag
	 documentation-string
	 default-getter
	 value-validator
	 owner-type)

  (let ((option-value (gncOwnerNew)))

    (define (convert-to-pair item)
      (if (pair? item)
	  item
	  (cons (gncOwnerGetType item)
		(gncOwnerReturnGUID item))))

    (define (convert-to-owner pair)
      (if (pair? pair)
	  (let ((type (car pair)))
	    (cond
	      ((eqv? type GNC-OWNER-CUSTOMER)
	       (gncOwnerInitCustomer
		option-value
		(gncCustomerLookupFlip (cdr pair) (gnc-get-current-book)))
	       option-value)

	       ((eqv? type GNC-OWNER-VENDOR)
		(gncOwnerInitVendor
		 option-value
		 (gncVendorLookupFlip (cdr pair) (gnc-get-current-book)))
		option-value)

	       ((eqv? type GNC-OWNER-EMPLOYEE)
		(gncOwnerInitEmployee
		 option-value
		 (gncEmployeeLookupFlip (cdr pair) (gnc-get-current-book)))
		option-value)

	       ((eqv? type GNC-OWNER-JOB)
		(gncOwnerInitJob
		 option-value
		 (gncJobLookupFlip (cdr pair) (gnc-get-current-book)))
		option-value)

	       (else '())))
	  pair))

    (let* ((option (convert-to-pair (default-getter)))
	   (option-set #f)
	   (getter (lambda () (convert-to-owner
			       (if option-set
				   option
				   (default-getter)))))
	   (value->string (lambda ()
			    (string-append
			     "'" (gnc:value->string
				  (if option-set option #f)))))
	   (validator
	    (if (not value-validator)
		(lambda (owner)
		  (let ((type (if (pair? owner)
                                  (car owner)
                                  (gncOwnerGetType owner))))
		    (if (equal? type owner-type)
			(list #t owner)
			(list #f "Owner-Type Mismatch"))))
		(lambda (owner)
		  (value-validator (convert-to-owner owner))))))

      (gnc:make-option
       section name sort-tag 'owner documentation-string getter
       (lambda (owner)
	 (if (null? owner) (set! owner (default-getter)))
         (set! owner (convert-to-owner owner))
         (let* ((result (validator owner))
		(valid (car result))
		(value (cadr result)))
	   (if valid
	       (begin
		 (set! option (convert-to-pair value))
		 (set! option-set #t))
	       (gnc:error "Illegal owner value set"))))
       (lambda () (convert-to-owner (default-getter)))
       (gnc:restore-form-generator value->string)
       (lambda (b p)
	 (qof-book-set-option b (symbol->string (car option))
				      (append p '("type")))
	 (qof-book-set-option b (cdr option)
				      (append p '("value"))))
       (lambda (b p)
	 (let ((t (qof-book-get-option b (append p '("type"))))
	       (v (qof-book-get-option b (append p '("value")))))
	   (if (and t v (string? t) (string? v))
	       (begin
		 (set! option (cons (string->symbol t) v))
		 (set! option-set #t)))))
       validator
       owner-type #f #f #f))))


;; Internally, values are always a guid. Externally, both guids and
;; taxtable pointers may be used to set the value of the option. The
;; option always returns a single taxtable pointer.

(define (gnc:make-taxtable-option
	 section
	 name
	 sort-tag
	 documentation-string
	 default-getter
	 value-validator)

  (define (convert-to-guid item)
    (if (string? item)
        item
        (gncTaxTableReturnGUID item)))

  (define (convert-to-taxtable item)
    (if (string? item)
        (gncTaxTableLookupFlip item (gnc-get-current-book))
        item))

  (let* ((option (convert-to-guid (default-getter)))
         (option-set #f)
         (getter (lambda () (convert-to-taxtable
			     (if option-set
				 option
				 (default-getter)))))
         (value->string (lambda ()
                          (string-append
                           "'" (gnc:value->string (if option-set option #f)))))
         (validator
          (if (not value-validator)
              (lambda (taxtable) (list #t taxtable))
              (lambda (taxtable)
                (value-validator (convert-to-taxtable taxtable))))))
    (gnc:make-option
     section name sort-tag 'taxtable documentation-string getter
     (lambda (taxtable)
       (if (null? taxtable) (set! taxtable (default-getter)))
       (set! taxtable (convert-to-taxtable taxtable))
       (let* ((result (validator taxtable))
	      (valid (car result))
	      (value (cadr result)))
	 (if valid
	     (begin
	       (set! option (convert-to-guid value))
	       (set! option-set #t))
	     (gnc:error "Illegal taxtable value set"))))
     (lambda () (convert-to-taxtable (default-getter)))
     (gnc:restore-form-generator value->string)
     (lambda (b p) (qof-book-set-option b option p))
     (lambda (b p)
       (let ((v (qof-book-get-option b p)))
	 (if (and v (string? v))
	     (begin
	       (set! option v)
	       (set! option-set #t)))))
     validator
     #f #f #f #f)))

;; This defines an option to set a counter value. This is a slightly
;; different kind of option: Unlike all other options, the values edited
;; by this option are not saved in the "options"/<section> kvm slot, but
;; in the "counters" slot. This is mostly due to backwards compatibility
;; and partly because counters are a bit different from other options
;; anyway.
;;
;; This is implemented by overriding the scm->kvp and kvp->scm methods
;; to ignore the kvp path passed and replace it with a hardcoded
;; "counters".
(define (gnc:make-counter-option
         section
         name
	 key
         sort-tag
         documentation-string
         default-value)
  (let ((option (gnc:make-number-range-option
                 section name sort-tag documentation-string
                 default-value 0 999999999 0 1)))
    (gnc:set-option-scm->kvp
     option
     (lambda (b p)
       (qof-book-set-option
        b (inexact->exact ((gnc:option-getter option)))
        (list "counters" key))))
    (gnc:set-option-kvp->scm
     option
     (lambda (b p)
       (let ((v (qof-book-get-option b (list "counters" key))))
         (if (and v (integer? v))
             ((gnc:option-setter option) v)))))
    option))

;; This defines an option to set a counter format, which has the same
;; exception as gnc:make-counter-option above.
;; Note this function uses a hack to make sure there never is a default value
;; (default-value is set to #f and value subsequently set to whatever was passed as default-value)
;; This hack was introduced to fix https://bugs.gnucash.org/show_bug.cgi?id=687504
(define (gnc:make-counter-format-option
         section
         name
         key
         sort-tag
         documentation-string
         default-value)
  (let ((option (gnc:make-string-option
                 section name sort-tag documentation-string #f)))
    (gnc:option-set-value option default-value)
    (gnc:set-option-scm->kvp
     option
     (lambda (b p)
       (let ((value ((gnc:option-getter option)))
             (path (string-concatenate (list "counter_formats/" key))))
         (qof-book-set-string-option b path value))))
    (gnc:set-option-kvp->scm
     option
     (lambda (b p)
       (let* ((path (string-concatenate (list "counter_formats/" key)))
              (v (qof-book-get-string-option b path)))
         (if (and v (string? v))
             ((gnc:option-setter option) v)))))
    option))

(export gnc:make-invoice-option)
(export gnc:make-customer-option)
(export gnc:make-vendor-option)
(export gnc:make-employee-option)
(export gnc:make-owner-option)
(export gnc:make-taxtable-option)
(export gnc:make-counter-option)
(export gnc:make-counter-format-option)