;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  qif-file.scm
;;;
;;;  Read a QIF file into a <qif-file> object.
;;;
;;;  Bill Gribble <grib@billgribble.com> 20 Feb 2000
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(use-modules (gnucash core-utils))
(use-modules (gnucash import-export string))
(use-modules (ice-9 regex))
(use-modules (srfi srfi-13))
(use-modules (ice-9 rdelim))

(define qif-bad-numeric-rexp
  (make-regexp "^\\.\\.\\."))

(define (not-bad-numeric-string? input)
  (let ((match (regexp-exec qif-bad-numeric-rexp input)))
    (if match #f #t)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  qif-file:read-file
;;
;;  Suck in all the lines. Don't do any string interpretation,
;;  just store the fields "raw".
;;
;;  The return value will be:
;;    success:   ()
;;    failure:   (#f error-message)
;;    warning:   (#t error-message)
;;    cancel:    #t
;;    exception: #f
;;
;; FIXME: This function really should be able to return multiple
;;        errors and warnings rather than a single one.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (qif-file:read-file self path ticker-map progress-dialog)

  ;; This procedure does all the work. We'll define it, then call it safely.
  (define (private-read)
    (let ((qstate-type #f)
          (current-xtn #f)
          (current-split #f)
          (current-account-name #f)
          (last-seen-account-name #f)
          (default-split #f)
          (first-xtn #f)
          (ignore-accounts #f)
          (private-retval '())
          (line-num 0)
          (line #f)
          (tag #f)
          (value #f)
          (abort-read #f)
          (delimiters (string #\cr #\nl))
          (file-stats #f)
          (file-size 0)
          (bytes-read 0))

      ;; This procedure simplifies handling of warnings.
      (define (mywarn . args)
        (let ((str (gnc:list-display-to-string
                     (append (list (_ "Line") " " line-num ": ") args))))
          (set! private-retval (list #t str))
          (qif-import:log progress-dialog "qif-file:read-file" str)))


      ;; This procedure simplifies handling of failures
      (define (myfail . args)
        (let ((str (gnc:list-display-to-string
                         (append (list (_ "Line") " " line-num ": ") args))))
          (set! private-retval (list #f str))
          (qif-import:log progress-dialog "qif-file:read-file"
                          (string-append str "\n" (_ "Read aborted.")))
          (set! abort-read #t)))

      (define (strip-bom)
	(let ((c1 (read-char)))
	  (if (char=? c1 (integer->char #xEF))
	    (let ((c2 (read-char)))
	      (if (char=? c2 (integer->char #xBB))
		  (let ((c3 (read-char)))
		    (if (char=? c3 (integer->char #xBF)) #t
			(begin
			  (unread-char c3)
			  (unread-char c2)
			  (unread-char c1)
			#f)))
		  (begin
		    (unread-char c2)
		    (unread-char c1)
		    #f)))
	    (begin
	      (unread-char c1)
	      #f))))

      (qif-file:set-path! self path)
      (if (not (access? path R_OK))
          ;; A UTF-8 encoded path won't succeed on some systems, such as
          ;; Windows XP. Try encoding the path according to the locale.
          (set! path (gnc-locale-from-utf8 path)))
      (set! file-stats (stat path))
      (set! file-size (stat:size file-stats))


      (if progress-dialog
          (gnc-progress-dialog-set-sub progress-dialog
                                       (string-append (_ "Reading") " " path)))

      (with-input-from-file path
        (lambda ()
	  (strip-bom)
          ;; loop over lines
          (let line-loop ()
            (set! line (read-delimited delimiters))
            (set! line-num (+ 1 line-num))
            (if (and (not (eof-object? line))
                     (not (string=? line "")))
                (begin
                  ;; Add to the bytes-read tally.
                  (set! bytes-read
                        (+ bytes-read 1 (string-length line)))

                  ;; Pick the 1-char tag off from the remainder of the line.
                  (set! tag (string-ref line 0))
                  (set! value (substring line 1))

                  ;; If the line doesn't conform to UTF-8, try a default
                  ;; character set conversion based on the locale. If that
                  ;; fails, remove any invalid characters.
                  (if (not (gnc-utf8? value))
                      (let ((converted-value (gnc-locale-to-utf8 value)))
                        (if (or (string=? converted-value "")
                                (not (gnc-utf8? converted-value)))
                            (begin
                              (set! value (gnc-utf8-strip-invalid-strdup value))
                              (mywarn
                               (_ "Some characters have been discarded.")
                               " " (_"Converted to: ") value))
                            (begin
                              (mywarn
                               (_ "Some characters have been converted according to your locale.")
                               " " (_"Converted to: ") converted-value)
                              (set! value converted-value)))))

                  (if (eq? tag #\!)
                      ;; The "!" tag has the highest precedence and is used
                      ;; to switch between different sections of the file.
                      (let ((old-qstate qstate-type))
                        (set! qstate-type (qif-parse:parse-bang-field value))
                        (case qstate-type
                          ;; Transaction list for a particular account
                          ((type:bank type:cash type:ccard type:invst type:port
                            #{type:oth a}#  #{type:oth l}# #{type:oth s}#)
                           (if ignore-accounts
                               (set! current-account-name
                                     last-seen-account-name))
                           (set! ignore-accounts #f)
                           (set! current-xtn (make-qif-xtn))
                           (set! default-split (make-qif-split))
                           (set! first-xtn #t))

                          ;; Class list
                          ((type:class)
                           (set! current-xtn (make-qif-class)))

                          ;; Category list
                          ((type:cat)
                           (set! current-xtn (make-qif-cat)))

                          ;; Account list
                          ((account)
                           (set! current-xtn (make-qif-acct)))

                          ;; Security list
                          ((type:security)
                           (set! current-xtn (make-qif-stock-symbol)))

                          ;; Memorized transaction list
                          ((type:memorized)
                           ;; Not supported. We really should warn the user.
                           #f)

                          ;; Security price list
                          ((type:prices)
                           ;; Not supported. We really should warn the user.
                           #f)

                          ((option:autoswitch)
                           (set! ignore-accounts #t))

                          ((clear:autoswitch)
                           (set! ignore-accounts #f))

                          (else
                           ;; Ignore any other "option:" identifiers and
                           ;; just return to the previously known !type
                           (if (string-match "^option:"
                                             (symbol->string qstate-type))
                               (begin
                                 (mywarn (_ "Ignoring unknown option") " '"
                                         qstate-type "'")
                                 (set! qstate-type old-qstate))))))


                      ;; It's not a "!" tag, so the meaning depends on what
                      ;; type of section we are currently working on.
                      (case qstate-type

                        ;;;;;;;;;;;;;;;;;;;;;;
                        ;; Transaction list ;;
                        ;;;;;;;;;;;;;;;;;;;;;;

                        ((type:bank type:cash type:ccard type:invst type:port
                          #{type:oth a}#  #{type:oth l}# #{type:oth s}#)
                         (case tag
                           ;; D : transaction date
                           ((#\D)
                            (qif-xtn:set-date! current-xtn value))

                           ;; T : total amount
                           ((#\T)
                            (if (and default-split
                                    (not-bad-numeric-string? value))
                                (qif-split:set-amount! default-split value)))

                           ;; P : payee
                           ((#\P)
                            (qif-xtn:set-payee! current-xtn value))

                           ;; A : address
                           ;; multiple "A" lines are appended together with
                           ;; newlines; some Quicken files have a lot of
                           ;; A lines.
                           ((#\A)
                            (qif-xtn:set-address!
                             current-xtn
                             (let ((current (qif-xtn:address current-xtn)))
                               (if (not (string? current))
                                   (set! current ""))
                               (string-append current "\n" value))))

                           ;; N : For transactions involving a security, this
                           ;; is the investment action. For all others,  this
                           ;; is a check number or transaction number.
                           ((#\N)
                            (if (or (eq? qstate-type 'type:invst)
                                    (eq? qstate-type 'type:port))
                                (qif-xtn:set-action! current-xtn value)
                                (qif-xtn:set-number! current-xtn value)))

                           ;; C : cleared flag
                           ((#\C)
                            (qif-xtn:set-cleared! current-xtn value))

                           ;; M : memo
                           ((#\M)
                            (if default-split
                                (qif-split:set-memo! default-split value)))

                           ;; I : share price (stock transactions)
                           ((#\I)
                            (qif-xtn:set-share-price! current-xtn value))

                           ;; Q : number of shares (stock transactions)
                           ((#\Q)
                            (qif-xtn:set-num-shares! current-xtn value))

                           ;; Y : name of security (stock transactions)
                           ((#\Y)
                            (qif-xtn:set-security-name! current-xtn value))

                           ;; O : commission (stock transactions)
                           ((#\O)
                            (qif-xtn:set-commission! current-xtn value))

                           ;; L : category
                           ((#\L)
                            (if default-split
                                (qif-split:set-category! default-split value)))

                           ;; S : split category
                           ;; At this point we are ignoring the default-split
                           ;; completely, but save it for later -- we need it
                           ;; to determine whether to reverse the split values.
                           ((#\S)
                            (set! current-split (make-qif-split))
                            (if default-split
                                (qif-xtn:set-default-split! current-xtn
                                                            default-split))
                            (set! default-split #f)
                            (qif-split:set-category! current-split value)
                            (qif-xtn:set-splits!
                               current-xtn
                               (cons current-split
                                     (qif-xtn:splits current-xtn))))

                           ;; E : split memo
                           ((#\E)
                            (if current-split
                                (qif-split:set-memo! current-split value)))

                           ;; $ : split amount (if there are splits)
                           ((#\$)
                            (if (and current-split
                                     (not-bad-numeric-string? value))
                                (qif-split:set-amount! current-split value)))

                           ;; ^ : end-of-record
                           ((#\^)
                            (if (null? (qif-xtn:splits current-xtn))
                                (qif-xtn:set-splits! current-xtn
                                                     (list default-split)))
                            (if first-xtn
                                (let ((opening-balance-payee
                                       (qif-file:process-opening-balance-xtn
                                        self current-account-name current-xtn
                                        qstate-type)))
                                  (if (not current-account-name)
                                      (set! current-account-name
                                            opening-balance-payee))
                                  (set! first-xtn #f)))

                            (if (and (or (eq? qstate-type 'type:invst)
                                         (eq? qstate-type 'type:port))
                                     (not (qif-xtn:security-name current-xtn)))
                                (qif-xtn:set-security-name! current-xtn ""))

                            (qif-xtn:set-from-acct! current-xtn
                                                    current-account-name)

                            (if (qif-xtn:date current-xtn)
                                (qif-file:add-xtn! self current-xtn)
                                ;; The date is missing! Warn the user.
                                (mywarn (_ "Date required.") " "
                                        (_ "Discarding this transaction.")))

                            ;;(write current-xtn) (newline)
                            (set! current-xtn (make-qif-xtn))
                            (set! current-split #f)
                            (set! default-split (make-qif-split)))))


                        ;;;;;;;;;;;;;;;;
                        ;; Class list ;;
                        ;;;;;;;;;;;;;;;;

                        ((type:class)
                         (case tag
                           ;; N : name
                           ((#\N)
                            (qif-class:set-name! current-xtn value))

                           ;; D : description
                           ((#\D)
                            (qif-class:set-description! current-xtn value))

                           ;; R : tax copy designator (ignored for now)
                           ((#\R)
                            #t)

                           ;; end-of-record
                           ((#\^)
                            (qif-file:add-class! self current-xtn)
                            (set! current-xtn (make-qif-class)))

                           (else
                            (mywarn (_ "Ignoring class line") ": " line))))


                        ;;;;;;;;;;;;;;;;;;
                        ;; Account List ;;
                        ;;;;;;;;;;;;;;;;;;

                        ((account)
                         (case tag
                           ((#\N)
                            (qif-acct:set-name! current-xtn value)
                            (set! last-seen-account-name value))
                           ((#\D)
                            (qif-acct:set-description! current-xtn value))
                           ((#\T)
                            (qif-acct:set-type! current-xtn value))
                           ((#\L)
                            (qif-acct:set-limit! current-xtn value))
                           ((#\B)
                            (qif-acct:set-budget! current-xtn value))
                           ((#\^)
                            (if (not ignore-accounts)
                                (set! current-account-name
                                      (qif-acct:name current-xtn)))
                            (qif-file:add-account! self current-xtn)
                            (set! current-xtn (make-qif-acct)))))


                        ;;;;;;;;;;;;;;;;;;;
                        ;; Category list ;;
                        ;;;;;;;;;;;;;;;;;;;

                        ((type:cat)
                         (case tag
                           ;; N : category name
                           ((#\N)
                            (qif-cat:set-name! current-xtn value))

                           ;; D : category description
                           ((#\D)
                            (qif-cat:set-description! current-xtn value))

                           ;; T : is this a taxable category?
                           ((#\T)
                            (qif-cat:set-taxable! current-xtn #t))

                           ;; E : is this an expense category?
                           ((#\E)
                            (qif-cat:set-expense-cat! current-xtn #t))

                           ;; I : is this an income category?
                           ((#\I)
                            (qif-cat:set-income-cat! current-xtn #t))

                           ;; R : tax form/line designator
                           ((#\R)
                            (qif-cat:set-tax-class! current-xtn value))

                           ;; B : budget amount.  not really supported.
                           ((#\B)
                            (qif-cat:set-budget-amt! current-xtn value))

                           ;; end-of-record
                           ((#\^)
                            (qif-file:add-cat! self current-xtn)
                            (set! current-xtn (make-qif-cat)))

                           (else
                            (mywarn (_ "Ignoring category line") ": " line))))


                        ;;;;;;;;;;;;;;;;;;;
                        ;; Security list ;;
                        ;;;;;;;;;;;;;;;;;;;

                        ((type:security)
                         (case tag
                           ;; N : stock name
                           ((#\N)
                            (qif-stock-symbol:set-name! current-xtn value))

                           ;; S : ticker symbol
                           ((#\S)
                            (qif-stock-symbol:set-symbol! current-xtn value))

                           ;; T : type
                           ((#\T)
                            (qif-stock-symbol:set-type! current-xtn value))

                           ;; G : asset class (ignored)
                           ((#\G)
                            #t)

                           ;; end-of-record
                           ((#\^)
                            (qif-ticker-map:add-ticker! ticker-map current-xtn)
                            (set! current-xtn (make-qif-stock-symbol)))

                           (else
                            (mywarn (_ "Ignoring security line") ": " line))))


                        ;; trying to sneak one by, eh?
                        (else
                          (if (and (not qstate-type)
                                   (not (string=? (string-trim line) "")))
                              (myfail
                                (_ "File does not appear to be in QIF format")
                                ": " line)))))

                  ;; Report the progress.
                  (if (and progress-dialog
                           (zero? (remainder line-num 32)))
                      (begin
                        (gnc-progress-dialog-set-value progress-dialog
                                                       (/ bytes-read file-size))
                        (qif-import:check-pause progress-dialog)
                        (if qif-import:canceled
                            (begin
                              (set! private-retval #t)
                              (set! abort-read #t)))))

                  ;; This is if we read a normal (non-null, non-eof) line...
                  (if (not abort-read)
                      (line-loop)))

                ;; ...and this is if we read a null or eof line.
                (if (and (not abort-read)
                         (not (eof-object? line)))
                    (line-loop))))) #:encoding "UTF-8")

      ;; Reverse the transaction list so xtns are in the same order that
      ;; they appeared in the file.  This is important in a few cases.
      (qif-file:set-xtns! self (reverse (qif-file:xtns self)))

      private-retval))


  (gnc:backtrace-if-exception
    (lambda ()
      (let ((retval #f))
        ;; Safely read the file.
        (set! retval (gnc:backtrace-if-exception private-read))

        ;; Fill the progress dialog.
        (if (and progress-dialog
                 (list? retval))
          (gnc-progress-dialog-set-value progress-dialog 1))

        retval))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  qif-file:process-opening-balance-xtn
;;
;;  This gets called for the first transaction after a !Type: tag.
;;
;;  If the first transaction after a !Type: tag has a payee of
;;  "Opening Balance", we have to massage the transaction a little.
;;  The meaning of an OB transaction is "transfer from Equity to the
;;  account specified in the L line." idiomatically, ms-money and some
;;  others use this transaction instead of an Account record to
;;  specify "this" account (the from-account for all following
;;  transactions), so we have to allow for that.
;;
;;  Even if the payee isn't "Opening Balance", we know that if there's
;;  no default from-account by this time, we need to set one.  In that
;;  case, we set the default account based on the file name.
;;
;;  If we DO know the account already, and this is a transfer to it,
;;  it's also an opening balance regardless of the payee.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (qif-file:process-opening-balance-xtn self acct-name xtn type)
  (let ((payee (qif-xtn:payee xtn))
        (category (qif-split:category (car (qif-xtn:splits xtn))))
        (cat-is-acct? (qif-split:category-is-account?
                       (car (qif-xtn:splits xtn))))
        (security (qif-xtn:security-name xtn)))
    (if (or (and (not acct-name)
                 (not security)
                 payee (string? payee)
                 (string=? (string-remove-trailing-space payee)
                           "Opening Balance")
                 cat-is-acct?)
            (and acct-name (string? acct-name)
                 (string=? acct-name category)
                 (not security)))
        ;; this is an explicit "Opening Balance" transaction.  we need
        ;; to change the category to point to the equity account that
        ;; the opening balance comes from.
        (begin
          (qif-split:set-category-private! (car (qif-xtn:splits xtn))
                                           (default-equity-account))
          (qif-split:set-category-is-account?! (car (qif-xtn:splits xtn)) #t)
          (set! acct-name category)))
    acct-name))

;; return #t if all xtns have a non-#f from-acct otherwise, we will
;; need to ask for an explicit account.
(define (qif-file:check-from-acct self)
  (let ((retval #t))
    (for-each
     (lambda (xtn)
       (if (not (qif-xtn:from-acct xtn))
           (set! retval #f)))
     (qif-file:xtns self))
    retval))

;; if the date format was ambiguous, this will get called to reparse.
(define (qif-file:reparse-dates self new-format)
  (check-and-parse-field
   qif-xtn:date qif-xtn:set-date! equal?
   qif-parse:check-date-format (list new-format)
   qif-parse:parse-date/format
   (qif-file:xtns self)
   qif-parse:print-date
   'error-on-ambiguity (lambda (t e) e) 'date
   (lambda (fraction) #t)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  qif-file:parse-fields
;;
;;  Take a previously-read qif file and convert fields from
;;  strings to the appropriate type.
;;
;;  The return value will be:
;;    success:   ()
;;    failure:   (#f . ((type . error) ...))
;;    warning:   (#t . ((type . error) ...))
;;    cancel:    #t
;;    exception: #f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (qif-file:parse-fields self progress-dialog)

  ;; This procedure does all the work. We'll define it, then call it safely.
  (define (private-parse)
   (let ((error #f)
         (update-count 0)
         (all-ok #f))

     ;; This procedure sets a suboperation name.
     (define (set-sub str)
       (if progress-dialog
           (gnc-progress-dialog-set-sub progress-dialog str))
       #t)


     ;; This procedure sets a suboperation weight.
     (define (start-sub weight)
       (if progress-dialog
           (gnc-progress-dialog-push progress-dialog weight))
       #t)


     ;; This procedure finishes a suboperation.
     (define (finish-sub)
       (if progress-dialog
           (gnc-progress-dialog-pop-full progress-dialog))
       #t)


     ;; This procedure handles progress reporting, pause, and cancel.
     (define (update-progress fraction)
       (set! update-count (+ 1 update-count))
       (if (and progress-dialog
                (zero? (remainder update-count 32)))
           (begin
             (gnc-progress-dialog-set-value progress-dialog fraction)
             (qif-import:check-pause progress-dialog)
             (if qif-import:canceled
                 (throw 'cancel)))))


     ;; This procedure is the generic error handler for parsing.
     (define (add-error t e)
       ;; Log the error message.
       (if (string? e)
           (qif-import:log progress-dialog
                           "qif-file:parse-fields"
                           (string-append (case t
                                            ((date) (_ "Transaction date"))
                                            ((split-amounts) (_ "Transaction amount"))
                                            ((share-price) (_ "Share price"))
                                            ((num-shares) (_ "Share quantity"))
                                            ((action) (_ "Investment action"))
                                            ((cleared) (_ "Reconciliation status"))
                                            ((commission) (_ "Commission"))
                                            ((acct-type) (_ "Account type"))
                                            ((tax-class) (_ "Tax class"))
                                            ((budget-amt) (_ "Category budget amount"))
                                            ((budget) (_ "Account budget amount"))
                                            ((limit) (_ "Credit limit"))
                                            (else (symbol->string t)))
                                          ": " e)))
       ;; Save the error condition.
       (if (not error)
           (set! error (list (cons t e)))
           (set! error (cons (cons t e) error))))


     (and
      ;;
      ;; Fields of categories.
      ;;
      (set-sub (_ "Parsing categories"))
      ;; The category tasks will be 5% of the overall parsing effort.
      (start-sub 0.05)

      ;; Tax classes; assume this is 50% of the category parsing effort.
      (start-sub 0.5)
      (check-and-parse-field
       qif-cat:tax-class qif-cat:set-tax-class! gnc-numeric-equal
       qif-parse:check-number-format '(decimal comma)
       qif-parse:parse-number/format (qif-file:cats self)
       qif-parse:print-number
       'guess-on-ambiguity add-error 'tax-class
       update-progress)
      (finish-sub)

      ;; Budget amounts; this is the last task for category parsing.
      (start-sub 1)
      (check-and-parse-field
       qif-cat:budget-amt qif-cat:set-budget-amt! gnc-numeric-equal
       qif-parse:check-number-format '(decimal comma)
       qif-parse:parse-number/format (qif-file:cats self)
       qif-parse:print-number
       'guess-on-ambiguity add-error 'budget-amt
       update-progress)
      (finish-sub)

      (finish-sub)


      ;;
      ;; Fields of accounts
      ;;
      (set-sub (_ "Parsing accounts"))
      ;; The account tasks will be 5% of the overall parsing effort.
      (start-sub 0.05)

      ;; Account limits; assume this is 20% of the account parsing effort.
      (start-sub 0.2)
      (check-and-parse-field
       qif-acct:limit qif-acct:set-limit! gnc-numeric-equal
       qif-parse:check-number-format '(decimal comma)
       qif-parse:parse-number/format (qif-file:accounts self)
       qif-parse:print-number
       'guess-on-ambiguity add-error 'limit
       update-progress)
      (finish-sub)

      ;; Budget amounts; assume this is 20% of the account parsing effort.
      (start-sub 0.2)
      (check-and-parse-field
       qif-acct:budget qif-acct:set-budget! gnc-numeric-equal
       qif-parse:check-number-format '(decimal comma)
       qif-parse:parse-number/format (qif-file:accounts self)
       qif-parse:print-number
       'guess-on-ambiguity add-error 'budget
       update-progress)
      (finish-sub)

      ;; Account types; this is the last task for account parsing.
      (start-sub 1)
      (parse-field
       qif-acct:type qif-acct:set-type!
       qif-parse:parse-acct-type (qif-file:accounts self)
       add-error 'acct-type
       update-progress)
      (finish-sub)

      (finish-sub)


      ;;
      ;; fields of transactions
      ;;
      (set-sub (_ "Parsing transactions"))
      ;; Transaction parsing takes up the rest of the overall parsing effort.
      (start-sub 1)

      ;; Dates; assume this is 15% of the transaction effort.
      (start-sub 0.15)
      (check-and-parse-field
       qif-xtn:date qif-xtn:set-date! equal?
       qif-parse:check-date-format '(m-d-y d-m-y y-m-d y-d-m)
       qif-parse:parse-date/format
       (qif-file:xtns self)
       qif-parse:print-date
       'error-on-ambiguity add-error 'date
       update-progress)
      (finish-sub)

      ;; Clear flags; assume this is 5% of the transaction effort.
      (start-sub 0.05)
      (parse-field
       qif-xtn:cleared qif-xtn:set-cleared!
       qif-parse:parse-cleared-field (qif-file:xtns self)
       add-error 'cleared
       update-progress)
      (finish-sub)

      ;; Investment actions; assume this is 10% of the transaction effort.
      (start-sub 0.1)
      (parse-field
       qif-xtn:action qif-xtn:set-action!
       qif-parse:parse-action-field (qif-file:xtns self)
       add-error 'action
       update-progress)
      (finish-sub)

      ;; Share prices; assume this is 10% of the transaction effort.
      (start-sub 0.1)
      (check-and-parse-field
       qif-xtn:share-price qif-xtn:set-share-price! gnc-numeric-equal
       qif-parse:check-number-format '(decimal comma)
       qif-parse:parse-number/format (qif-file:xtns self)
       qif-parse:print-number
       'guess-on-ambiguity add-error 'share-price
       update-progress)
      (finish-sub)

      ;; Share quantities; assume this is 10% of the transaction effort.
      (start-sub 0.1)
      (check-and-parse-field
       qif-xtn:num-shares qif-xtn:set-num-shares! gnc-numeric-equal
       qif-parse:check-number-format '(decimal comma)
       qif-parse:parse-number/format (qif-file:xtns self)
       qif-parse:print-number
       'guess-on-ambiguity add-error 'num-shares
       update-progress)
      (finish-sub)

      ;; Commissions; assume this is 10% of the transaction effort.
      (start-sub 0.1)
      (check-and-parse-field
       qif-xtn:commission qif-xtn:set-commission! gnc-numeric-equal
       qif-parse:check-number-format '(decimal comma)
       qif-parse:parse-number/format (qif-file:xtns self)
       qif-parse:print-number
       'guess-on-ambiguity add-error 'commission
       update-progress)
      (finish-sub)

      ;; Splits; this is the rest of the transaction effort.
      (start-sub 1)
      ;; this one's a little tricky... it checks and sets all the
      ;; split amounts for the transaction together.
      (check-and-parse-field
       qif-xtn:split-amounts qif-xtn:set-split-amounts! gnc-numeric-equal
       qif-parse:check-number-formats '(decimal comma)
       qif-parse:parse-numbers/format (qif-file:xtns self)
       qif-parse:print-numbers
       'guess-on-ambiguity add-error 'split-amounts
       update-progress)
      (finish-sub)

      (finish-sub)


      (begin
        (set! all-ok #t)
        #t))

     ;; Determine what to return.
     (cond (qif-import:canceled
            #t)
           (error
            (cons all-ok error))
           (else '()))))


  ;; Safely read the file and return the result.
  (gnc:backtrace-if-exception
    (lambda () (catch 'cancel private-parse (lambda (key . args) #t)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  parse-field
;;
;;  A simplified version of check-and-parse-field which just
;;  calls the parser on every instance of the field in the set
;;  of objects.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (parse-field getter setter parser objects errorproc errortype reporter)
  (let ((work-to-do (length objects))
        (work-done 0)
        (unparsed #f))
    (for-each
     (lambda (obj)
       (set! unparsed (getter obj))
       (if (and unparsed (string? unparsed))
           (setter obj (parser unparsed errorproc errortype)))
       (set! work-done (+ 1 work-done))
       (reporter (/ work-done work-to-do)))
     objects))
  #t)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  check-and-parse-field
;;
;;  This is a semi-generic routine to apply a format check and
;;  parsing routine to fields that can have multiple possible
;;  formats.  In this case, any amount field cam be decimal or
;;  comma radix and the date field can be any of several possible
;;  types.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (check-and-parse-field getter setter equiv-thunk checker
                               formats parser objects printer
                               on-error errorproc errortype
                               reporter)
  (let* ((do-parsing #f)
         (retval #t)
         (format #f)
         (len (length objects))
         (work-to-do (* len 2))
         (work-done 0))

    ;; first find the right format for the field
    ;; loop over objects.  If the formats list ever gets down
    ;; to 1 element, we can stop right there.
    (if (not (null? objects))
        (let loop ((current (car objects))
                   (rest (cdr objects)))
          (let ((val (getter current)))
            (if val
                (begin
                  (set! do-parsing #t)
                  (set! formats (checker val formats))))
            (set! work-done (+ 1 work-done))
            (reporter (/ work-done work-to-do)))
          (if (and (not (null? formats))
                   ;; (not (null? (cdr formats)))
                   (not (null? rest)))
              (loop (car rest) (cdr rest)))))

    ;; if there's nothing left in formats, there's no format that will
    ;; fit all the values for a given field.  We have to give up at
    ;; that point.

    ;; If there are multiple items in formats, we look at the on-error
    ;; arg.  If it's 'guess-on-ambiguity, we take the default (first)
    ;; item in the list.  This is not super great.  if it's
    ;; 'fail-on-ambiguity (or anything else, actually) we return the
    ;; list of acceptable formats.

    (cond
     ((or (not formats)
          (null? formats))
      ;; Data was not in any of the supplied formats.
      (errorproc errortype (_ "Unrecognized or inconsistent format."))
      (set! retval #f)
      (set! do-parsing #f))

     ((and (not (null? (cdr formats))) do-parsing)
      ;; There are multiple formats that fit.  If they all produce the
      ;; same interpretation for every data point in the set, then
      ;; just ignore the format ambiguity.  Otherwise, it's really an
      ;; error.  ATM since there's no way to correct the error let's
      ;; just leave it be.
      (if (or (eq? on-error 'guess-on-ambiguity)
              (all-formats-equivalent? getter parser equiv-thunk formats
                                       objects printer errorproc errortype))
          (set! format (car formats))
          (begin
            (errorproc errortype formats)
            (set! do-parsing #f)
            ;; NOTE: It seems like this ought to be (set! retval #f) instead,
            ;;       but that would stop all parsing dead in its tracks. Not
            ;;       sure that this can happen to anything other than dates,
            ;;       and those will get reparsed anyway.
            (set! retval #t))))
     (else
      (set! format (car formats))))

    ;; do-parsing is false if there were no objects with non-#f values
    ;; in the field, or the data format is ambiguous and
    ;; 'fail-on-ambiguity was passed.  We would have had to look at
    ;; all of them once, but at least not twice.
    (if do-parsing
        (for-each
          (lambda (current)
            (let ((val (getter current))
                  (parsed #f))
              (if val
                  (begin
                    (set! parsed (parser val format))
                    (if parsed
                        (setter current parsed)
                        (begin
                          (set! retval #f)
                          (errorproc errortype
                           (_ "Parsing failed.")))))))
            (set! work-done (+ 1 work-done))
            (reporter (/ work-done work-to-do)))
         objects))

    (if retval
        (reporter 1))

    retval))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  all-formats-equivalent?
;;
;;  This predicate checks for the off chance that even though
;;  there are multiple possible interpretations they are all the
;;  same. (i.e. the numbers "1000 2000 3000 4000" could be
;;  interpreted as decimal or comma radix, but who cares?  The
;;  values will be the same).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (all-formats-equivalent? getter parser equiv-thunk formats objects
                                 printer errorproc errortype)
  (let ((all-ok #t))
    (let obj-loop ((objlist objects))
      (let* ((unparsed (getter (car objlist)))
             (parsed #f))
        (if (string? unparsed)
            (begin
              ;; Parse using the first format in the list.
              (set! parsed (parser unparsed (car formats)))
              ;; For each remaining format, see if the result is the same.
              (for-each
               (lambda (fmt)
                 (let ((this-parsed (parser unparsed fmt)))
                   (if (not (equiv-thunk parsed this-parsed))
                       (begin
                         (set! all-ok #f)
                         (if (not (eq? errortype 'date))
                             (errorproc errortype
                                        (gnc:list-display-to-string (list
                              (_ "Parse ambiguity between formats") " "
                              formats "\n"
                              (format #f (_ "Value '~a' could be ~a or ~a.")
                                       parsed
                                       (printer parsed)
                                       (printer this-parsed))))))))))
               (cdr formats))))
        (if (and all-ok (not (null? (cdr objlist))))
            (obj-loop (cdr objlist)))))
    all-ok))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  qif-file:parse-fields-results
;;
;;  Take the results from qif-file:parse fields and find the
;;  first result for a particular type of parse.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (qif-file:parse-fields-results results type)
  (define (test-results results)
    (if (null? results) #f
        (let* ((this-res (car results))
               (this-type (car this-res)))
          (if (eq? this-type type)
              (cdr this-res)
              (test-results (cdr results))))))

  (if results (test-results results) #f))
