pta-ledger/pta-ledger.lisp

(in-package #:pta-ledger)

(defstruct amount quantity commodity)
(defstruct posting
  status account amount unit-price total-price comment)
(defstruct entry
  date secondary-date status code description comment postings)

(define-condition journal-failed (error)
  ((position :initarg :position :reader parse-error-pos)
   (left-data :initarg :left-data :reader parse-error-left))
  (:report (lambda (condition stream)
             (with-slots (position left-data) condition
               (format stream "Ledger parse failed at position ~A~@[, starting from ~A~]" position left-data)))))

(defun parse-journal (str)
  (let ((*default-year* (car (get-date (get-universal-time)))))
    (multiple-value-bind (result left rest)
        (parse (.journal) str)
      (cond
        ((null result) (error 'journal-failed :left-data (subseq str 0 (min 200 (length str)))))
        ((not (string= "" left)) (error 'journal-failed
                                        :position (- (length str)
                                                     (length left))
                                        :left-data (subseq left 0 (min 200 (length left)))))
        ((not (null rest)) (error 'journal-failed :position (length str)))
        (:otherwise result)))))

(defun parse-query (query)
  (let ((predicate (parse (.query) query)))
    (unless predicate
      (error "bad query: ~A" query))
    predicate))

(defun get-commodity (amount)
  (let ((com (amount-commodity amount)))
    (cond
      ((null com) *default-commodity*)
      ((equal com "$") "USD")
      ((equal com "€") "EUR")
      (t com))))

(defun add-amounts! (sum amounts)
  (dolist (a amounts sum)
    (let* ((commodity (get-commodity a))
           (same (find commodity sum :key #'amount-commodity :test #'equal)))
      (unless same (setf same (car (push (make-amount :quantity 0 :commodity commodity)
                                         sum))))
      (incf (amount-quantity same)
            (amount-quantity a)))))

(defun complement-amounts (postings &optional cost)
  (let ((sum
         (reduce #'add-amounts! postings :initial-value nil
                 :key #'(lambda (p) (when (posting-amount p)
                                      (get-amounts p cost))))))
    (dolist (a sum sum)
      (setf (amount-quantity a)
            (- (amount-quantity a))))))

(defun get-amounts (posting postings &optional cost)
  (let ((amount (posting-amount posting))
        (unit-price (posting-unit-price posting))
        (total-price (posting-total-price posting)))
    (if amount
        (if cost
            (if total-price (list total-price)
                (if unit-price
                    (list (make-amount :commodity (amount-commodity unit-price)
                                       :quantity (* (amount-quantity amount)
                                                    (amount-quantity unit-price))))
                    (list amount)))
            (list amount))
        (complement-amounts postings cost))))

(defun entries (journal &optional predicate)
  (remove-if (lambda (e)
               (when predicate
                 (not (some (lambda (p)
                              (funcall predicate e p))
                            (entry-postings e)))))
             (mapcar #'cdr (remove :entry journal :key #'car :test-not #'eql))))

(defun balance (entries &key predicate cost)
  (let ((balance (make-hash-table :test #'equal)))
    (dolist (entry entries balance)
      (dolist (posting (entry-postings entry))
        (when (or (null predicate)
                  (funcall predicate entry posting))
          (let* ((account (posting-account posting))
                 (amounts (get-amounts posting (entry-postings entry) cost)))
            (setf (gethash account balance)
                  (add-amounts! (gethash account balance) amounts)
                  (gethash "TOTALS" balance)
                  (add-amounts! (gethash "TOTALS" balance) amounts))))))))

(defun format-balance (balance)
  (let* ((accounts (alexandria:hash-table-keys balance)))
    (with-output-to-string (s)
      (loop for account in (sort accounts #'string<)
         for amounts = (remove 0 (gethash account balance) :test #'equal :key #'amount-quantity)
	 do (loop for amount in amounts
	       for first = t then nil
	       for amount-text = (render amount)
	       do (format s "~vA ~A~%"
			  (- *posting-length*
			     (position #\Space amount-text))
			  (if first account "")
			  amount-text))))))

(defun journal-balance (journal &optional query)
  (format-balance (balance (entries journal)
                           :predicate (when query (parse-query query)))))

(defun accounts (entries &key predicate)
  (let ((accounts (make-hash-table :test #'equal)))
    (dolist (entry entries (alexandria:hash-table-keys accounts))
      (dolist (posting (entry-postings entry))
        (when (or (null predicate)
                  (funcall predicate entry posting))
          (setf (gethash (posting-account posting) accounts) t))))))

(defun journal-accounts (journal &optional query)
  (accounts (entries journal)
            :predicate (when query (parse-query query))))

(defun journal-entries (journal &optional query)
  (entries journal (when query (parse-query query))))

(defun journal-print (journal &optional query)
  (mapcar #'render (journal-entries journal query)))

(defun clone-entry (entry)
  (parse (.entry) (render entry)))