pta-ledger/render.lisp

(in-package #:pta-ledger)

(defvar *posting-length* 46 "Length of posting without amount")
(defvar *allowed-statuses* '(#\! #\*))

(defun render-date (universal-time)
  (when universal-time
    (format nil "~{~4,'0D/~2,'0D/~2,'0D~}" (get-date universal-time))))

(defun when-allowed (status)
  (find status *allowed-statuses*))

(defgeneric render (object &optional stream)
  (:documentation "Render OBJECT to STREAM in text format."))

(defmethod render ((null null) &optional stream)
  (declare (ignore stream)))

(defmethod render ((amount amount) &optional stream)
  (format stream "~$ ~A" (amount-quantity amount) (amount-commodity amount)))

(defmethod render ((posting posting) &optional stream)
  (with-slots (status virtual account amount unit-price total-price comment) posting
    (let* ((amount-text (render amount))
           (status-text (format nil "~@[~A ~]" (when-allowed status)))
           (account (if virtual
                        (format nil "~A~A~A" virtual account
                                (ecase virtual
                                  (#\( #\))
                                  (#\[ #\])))
                        account))
           (text (format nil "    ~A~vA~@[  ~A~]~@[ @ ~A~]~@[ @@ ~A~]"
                         status-text
                         (if amount-text (- *posting-length*
                                            (position #\Space amount-text)
                                            (length status-text)) 0)
                         account
                         amount-text
                         (when unit-price (render unit-price))
                         (when total-price (render total-price))))
           (comments (split comment))
           (first-comment (first comments))
           (rest-comments (rest comments)))
      (format stream "~A~@[ ; ~A~]~{~%~vA ; ~A~}" text first-comment
              (loop for comment in rest-comments append (list (length text) "" comment))))))

(defmethod render ((entry entry) &optional stream)
  (with-slots (date secondary-date status code description comment postings) entry
    (let* ((text (format nil "~A~@[=~A~]~@[ ~A~]~@[ (~A)~]~@[ ~A~]"
                         (render-date date) (render-date secondary-date)
                         (when-allowed status) code description))
           (comments (split comment))
           (first-comment (first comments))
           (rest-comments (rest comments)))
      (format stream "~A~@[ ; ~A~]~{~%~vA ; ~A~}~{~%~A~}" text first-comment
              (loop for comment in rest-comments append (list (length text) "" comment))
              (loop for posting in postings collect (render posting))))))