pta-ledger/pta-ledger.lisp

(in-package #:pta-ledger)

(defstruct amount quantity commodity)
(defstruct posting
  status virtual 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 ((options (parse (.query) query)))
    (unless options
      (error "bad query: ~A" query))
    options))

(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 (and (posting-amount p)
                                               (null (posting-virtual 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 (eq cost :t)
            (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 &key predicate real &allow-other-keys)
  (remove-if (lambda (e)
               (let ((postings (entry-postings e)))
                 (or (and predicate (not (member nil postings :key #'(lambda (p) (funcall predicate e p)) :test-not #'eql)))
                     (and (eq real :t) (not (member nil (entry-postings e) :key #'posting-virtual)))
                     (and (eq real :f) (not (member nil (entry-postings e) :key #'posting-virtual :test-not #'eql))))))
             (mapcar #'cdr (remove :entry journal :key #'car :test-not #'eql))))

(defun select-postings (entry &key predicate real)
  (labels ((valid (posting)
             (and (or (null predicate)
                      (funcall predicate entry posting))
                  (or (null real)
                      (ecase real
                        (:t (null (posting-virtual posting)))
                        (:f (posting-virtual posting)))))))
    (remove-if-not #'valid (entry-postings entry))))

(defun account-parents (account &key tree)
  (append
   (when (eq tree :t)
     (loop for start = 0 then (1+ pos)
        for pos = (position #\: account :start start)
        while pos collect (subseq account 0 pos)))
   (list account "TOTALS")))

(defun remove-extra-parents! (balance)
  (labels ((find-child (parent amounts)
             (let ((len (length parent)))
               (loop for child being the hash-keys in balance
                  when (and (> (length child) (1+ len))
                            (equal parent (subseq child 0 len))
                            (equal (elt child len) #\:)
                            (equalp amounts (gethash child balance)))
                  do (return-from find-child t)))))
    (loop for parent being the hash-keys of balance using (hash-value amounts)
       when (find-child parent amounts)
       do (remhash parent balance))))

(defun balance (entries &key predicate cost real tree)
  (let ((balance (make-hash-table :test #'equal)))
    (dolist (entry entries)
      (dolist (posting (select-postings entry :predicate predicate :real real))
        (let ((amounts (get-amounts posting (entry-postings entry) cost)))
          (dolist (account (account-parents (posting-account posting) :tree tree))
            (setf (gethash account balance)
                  (add-amounts! (gethash account balance) amounts))))))
    (when (eq tree :t)
      (remove-extra-parents! balance))
    balance))

(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)
  (let ((balance (apply #'balance (entries journal)
                        (when query (parse-query query)))))
    (unless (zerop (hash-table-count balance))
      (format-balance balance))))

(defun accounts (entries &key predicate real &allow-other-keys)
  (let ((accounts (make-hash-table :test #'equal)))
    (dolist (entry entries (alexandria:hash-table-keys accounts))
      (dolist (posting (select-postings entry :predicate predicate :real real))
        (setf (gethash (posting-account posting) accounts) t)))))

(defun journal-accounts (journal &optional query)
  (apply #'accounts (entries journal)
         (when query (parse-query query))))

(defun journal-entries (journal &optional query)
  (apply #'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)))