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))
         (max-account-length (if accounts (apply #'max (mapcar #'length accounts)) 20)))
    (with-output-to-string (s)
      (loop for account in (sort accounts #'string<)
         for amounts = (gethash account balance)
         when (find 0 amounts :test-not #'= :key #'amount-quantity)
         do (format s "~vA  ~$ ~A~{~%~va  ~$ ~A~}~%" max-account-length account
                    (amount-quantity (car amounts)) (amount-commodity (car amounts))
                    (apply #'append (mapcar #'(lambda (a)
                                                (list max-account-length ""
                                                      (amount-quantity a)
                                                      (amount-commodity a)))
                                            (rest amounts))))))))

(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-print (journal &optional query)
  (mapcar #'render (entries journal (when query (parse-query query)))))