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)

(defvar *default-year* nil "Initialized to current year on parsing start. Could be set with directive")
(defvar *default-commodity* "RUB" "Could be set with directive")

(defparameter +day+ (* 60 60 24) "day in seconds")
(defun get-date (universal-time)
  (nreverse (subseq (multiple-value-list (decode-universal-time universal-time)) 3 6)))
(defun get-ut (year month day)
  (encode-universal-time 0 0 0 day month year))

(defun strip-space (text)
  (subseq text (or (position #\Space text :test-not 'eql) 0)
          (1+ (or (position #\Space text :test-not 'eql :from-end t) -1))))

(defun .date-delimiter ()
  (.is #'member '(#\/ #\- #\.)))

(defun .chars (&rest chars)
  (.is #'member chars))

;; optimized (.first (.map 'list parser at-least))
(defun .while (parser &key result-type (at-least 1))
  (lambda (input)
    (loop
       for inp = input then (input-rest inp)
       for count from 0
       until (input-empty-p inp)
       while (funcall parser inp)
       finally (return (when (>= count at-least)
                         (list (cons (when result-type
                                       (coerce (subseq input 0 count) result-type))
                                     inp)))))))

(defun .until (parser &key result-type (at-least 1))
  (.while (.not parser) :result-type result-type :at-least at-least))

(defun .mapcar* (parser &optional skip)
  (lambda (input)
    (loop
       with results
       until (input-empty-p input)
       for result = (run parser input)
       while result
       do
         (unless skip (push (caar result) results))
         (setf input (cdar result))
       finally (return (list (cons (unless skip (nreverse results)) input))))))

(defun .list (&rest parsers)
  (if (not parsers)
      (.fail)
      (.let* ((first (first parsers))
              (rest (if (rest parsers)
                        (apply #'.list (rest parsers))
                        (.identity nil))))
        (.identity (cons first rest)))))

(defun .number (&optional (at-least 1))
  (.let* ((digits (.while (.is #'digit-char-p) :result-type 'string :at-least at-least)))
    (.identity (parse-integer digits))))

(defun .spaces (&key (at-least 1) result-type)
  (.while (.char= #\Space) :result-type result-type :at-least at-least))

(defun .whitespace (&key (at-least 1) result-type)
  (.while (.chars #\Space #\Tab) :result-type result-type :at-least at-least))

(defun .eol ()
  (.or (.char= #\Newline)
       (.and (.not (.item))
             (.identity '()))))

(defun .line-comment ()
  (.let* ((_ (.whitespace :at-least 0))
          (_ (.chars #\; #\# #\*))
          (text (.until (.char= #\Newline) :at-least 0 :result-type 'string))
          (_ (.eol)))
    (.identity (strip-space text))))

(defun .multi-line-comment ()
  (.let* ((_ (.string= "comment"))
          (text (.until (.progn (.eol) (.string= "end comment")) :result-type 'string))
          (_ (.optional (.progn (.eol) (.string= "end comment"))))
          (_ (.eol)))
    (.identity (strip-space text))))

(defun .comment ()
  (.let* ((_ (.char= #\;))
          (text (.until (.char= #\Newline) :at-least 0 :result-type 'string)))
    (.identity (strip-space text))))

(defun .empty-lines ()
  (.mapcar*
   (.or (.progn (.whitespace :at-least 0) (.eol))
        (.line-comment)
        (.multi-line-comment))
   t))

(defun .simple-date (&optional default-year)
  (.let* ((year (.optional (.prog1 (.number 4) (.date-delimiter))))
          (month (.prog1 (.number) (.date-delimiter)))
          (day (.number)))
    (handler-case
        (.identity (get-ut (or year default-year *default-year*) month day))
      (error () (.fail)))))

(defun .status ()
  (.is 'member '(#\! #\*)))

(defun .code ()
  (.prog2 (.char= #\()
          (.until (.char= #\)) :result-type 'string :at-least 0)
          (.char= #\))))

(defun .description ()
  (.let* ((text (.until (.chars #\Newline #\;) :result-type 'string)))
    (.identity (strip-space text))))

(defun .account ()
  (.let* ((account (.until (.or (.string= "  ")
                                (.char= #\Newline)) :result-type 'string)))
    (.identity (strip-space account))))

(defun .money-number (thousands-sep decimal-sep)
  (.let* ((first-part (.while (.is 'digit-char-p) :result-type 'string))
          (rest-parts (.mapcar* (.progn (.char= thousands-sep)
                                        (.while (.is 'digit-char-p) :result-type 'string))))
          (decimals (.optional (.progn (.char= decimal-sep)
                                       (.while (.is 'digit-char-p) :result-type 'list :at-least 0)))))
    ;; One thousands separator and no decimals - is other way around, fail for other to succeceed
    (if (and (= 1 (length rest-parts))
             (null decimals))
        (.fail)
        (.identity
         (+
          (parse-integer (apply 'concatenate 'string (cons first-part rest-parts)))
          (if decimals
              (* (parse-integer (coerce decimals 'string))
                 (expt 10 (- (length decimals))))
              0))))))

(defun .money ()
  (.plus (.money-number #\, #\.)
         (.money-number #\. #\,)))

(defun .commodity ()
  (.or (.until (.or (.chars #\. #\, #\Space #\" #\; #\Newline #\- #\+ #\@)
                    (.is 'digit-char-p))
               :result-type 'string)
       (.prog2 (.char= #\")
               (.until (.char= #\") :result-type 'string)
               (.char= #\"))))

(defun .amount ()
  (.or
   (.let* ((sign1 (.optional (.chars #\- #\+)))
           (commodity (.prog1 (.commodity) (.optional (.whitespace))))
           (sign2 (.optional (.chars #\- #\+)))
           (quantity (.money)))
     (if (and sign1 sign2)
         (.fail)
         (.identity
          (make-amount :quantity (if (or (equal sign1 #\-)
                                         (equal sign2 #\-))
                                     (- quantity)
                                     quantity)
                       :commodity commodity))))
   (.let* ((sign (.optional (.chars #\- #\+)))
           (quantity (.money))
           (commodity (.optional (.progn (.optional (.whitespace))
                                         (.commodity)))))
     (.identity
      (make-amount :quantity (if (equal sign #\-)
                                 (- quantity)
                                 quantity)
                   :commodity commodity)))))

(defun .posting ()
  (.let* ((_ (.whitespace))
          (status (.optional (.prog1 (.status) (.optional (.spaces)))))
          (account (.account))
          (amount (.optional (.prog2 (.whitespace :at-least 2) (.amount) (.optional (.whitespace)))))
          (unit-price (.optional (.progn (.char= #\@)
                                         (.not (.char= #\@))
                                         (.optional (.whitespace))
                                         (.amount))))
          (_ (.optional (.whitespace)))
          (total-price (.optional (.progn (.string= "@@")
                                          (.optional (.whitespace))
                                          (.amount))))
          (_ (.optional (.whitespace)))
          (comment (.optional (.comment)))
          (_ (.eol))
          (comments (.mapcar* (.prog2 (.whitespace) (.comment) (.eol)))))
    (if (and unit-price total-price) (.fail)
        (.identity (make-posting
                    :status status
                    :account account
                    :amount amount
                    :unit-price unit-price
                    :total-price total-price
                    :comment (when (or comment comments)
                               (format nil "~{~A~^~%~}" (remove nil (list* comment comments)))))))))

(defun .entry ()
  (.let* ((date (.simple-date))
          (secondary-date (.optional (.progn (.char= #\=)
                                             (.simple-date (car (get-date date))))))
          (status (.optional (.progn (.spaces) (.status))))
          (code (.optional (.progn (.spaces) (.code))))
          (_ (.optional (.whitespace)))
          (description (.optional (.description)))
          (_ (.optional (.whitespace)))
          (comment (.optional (.comment)))
          (_ (.eol))
          (comments (.mapcar* (.prog2 (.whitespace) (.comment) (.eol))))
          (postings (.mapcar* (.posting))))
    (.identity (make-entry :date date
                           :secondary-date secondary-date
                           :status status
                           :code code
                           :description description
                           :comment (when (or comment comments)
                                      (format nil "~{~A~^~%~}" (remove nil (list* comment comments))))
                           :postings postings))))

(defun .wrap (prefix parser)
  (.let* ((value parser))
    (.identity (cons prefix value))))

(defun .journal ()
  (.prog1
   (.mapcar*
    (.progn
     (.empty-lines)
     (.or
      (.wrap :entry (.entry))
      (.prog1
       (.or
        (.wrap :market-price
               (.progn (.char= #\P)
                       (.optional (.whitespace))
                       (.let* ((date (.simple-date))
                               (_ (.whitespace))
                               (commodity (.commodity))
                               (_ (.whitespace))
                               (unit-price (.amount)))
                         (.identity (list date commodity unit-price)))))
        (.wrap :commodity
               (.progn (.string= "commodity")
                       (.whitespace)
                       (.amount)))
        (.wrap :default-commodity
               (.progn (.char= #\D)
                       (.optional (.whitespace))
                       (.amount)))
        (.wrap :default-year
               (.progn (.char= #\Y)
                       (.optional (.whitespace))
                       (.number))))
       (.optional (.whitespace))
       (.eol)))))
   (.empty-lines)))

(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 .query-coloned (type key-parser value-parser)
  (.let* ((key key-parser)
          (_ (.char= #\:))
          (value value-parser))
    (.identity (cons type
                     #'(lambda (entry posting)
                         (let ((key-value (funcall key entry posting)))
                           (or (eql key-value :t)
                               (funcall value key-value))))))))

(defun .query-entryp (prefix key)
  (.progn (.string= prefix) (.identity #'(lambda (e p) (declare (ignore p)) (funcall key e)))))

(defun .query-postingp (prefix key)
  (.progn (.string= prefix) (.identity #'(lambda (e p) (declare (ignore e)) (funcall key p)))))

(defun .query-value-regex ()
  (.let* ((regex (.until (.eol) :result-type 'string)))
    (handler-case
        (let ((matcher (cl-ppcre:create-scanner regex :case-insensitive-mode t)))
          (.identity #'(lambda (value)
                         (cl-ppcre:scan matcher value))))
      (error ()
        (.fail)))))

(defun .query-value-amount ()
  (.let* ((op (.or (.string= ">=")
                   (.string= "<=")
                   (.char= #\=)
                   (.char= #\<)
                   (.char= #\>)
                   (.identity #\=)))
          (value (.number)))
    (.identity #'(lambda (v)
                   (funcall (find-symbol (string op)) v value)))))

(defun .month ()
  (.or (.progn (.or (.string= "january") (.string= "jan")) (.identity 1))
       (.progn (.or (.string= "february") (.string= "feb")) (.identity 2))
       (.progn (.or (.string= "march") (.string= "mar")) (.identity 3))
       (.progn (.or (.string= "april") (.string= "apr")) (.identity 4))
       (.progn (.string= "may") (.identity 5))
       (.progn (.or (.string= "june") (.string= "jun")) (.identity 6))
       (.progn (.or (.string= "july") (.string= "jul")) (.identity 7))
       (.progn (.or (.string= "august") (.string= "aug")) (.identity 8))
       (.progn (.or (.string= "september") (.string= "sep")) (.identity 9))
       (.progn (.or (.string= "october") (.string= "oct")) (.identity 10))
       (.progn (.or (.string= "november") (.string= "nov")) (.identity 11))
       (.progn (.or (.string= "december") (.string= "dec")) (.identity 12))))

(defun week-start-date (universal-time &optional offset)
  (get-date (- universal-time (* +day+ (+ (nth 6 (multiple-value-list (decode-universal-time universal-time)))
                                          (- (* 7 (or offset 0))))))))

(defun month-start-date (year month &optional offset)
  (multiple-value-bind (year-offset month) (floor (+ month (or offset 0) -1) 12)
    (list (+ year year-offset) (1+ month) 1)))

(defun .smart-range (parser &optional duration)
  (.let* ((date parser))
    (destructuring-bind (&optional year month day) date
      (handler-case
          (let* ((ut (get-ut (or year (car (get-date (get-universal-time))))
                             (or month 1) (or day 1)))
                 (date (get-date ut)))
            (.identity (cons ut
                             (if duration (+ ut duration)
                                 (if day (+ ut +day+)
                                     (if month (apply #'get-ut (month-start-date (car date) (cadr date) 1))
                                         (get-ut (1+ year) 1 1)))))))
        (error () (.fail))))))

(defun .smart-date ()
  (let* ((now (get-universal-time))
         (date-now (get-date now)))
    (.or (.smart-range (.list (.prog1 (.number 4) (.date-delimiter))
                              (.prog1 (.number) (.date-delimiter))
                              (.number)))
         (.smart-range (.list (.prog1 (.number 4) (.date-delimiter))
                              (.number)
                              (.identity nil)))
         (.smart-range (.list (.number 4) (.identity nil) (.identity nil)))
         (.smart-range (.list (.identity nil)
                              (.prog1 (.number) (.date-delimiter))
                              (.number)))
         (.smart-range (.list (.identity nil) (.month) (.identity nil)))
         (.smart-range (.progn (.string= "today") (.identity date-now)))
         (.smart-range (.progn (.string= "yesterday") (.identity (get-date (- now +day+)))))
         (.smart-range (.progn (.string= "tomorrow") (.identity (get-date (+ now +day+)))))
         (.let* ((offset (.or (.progn (.string= "this") (.identity 0))
                              (.progn (.string= "last") (.identity -1))
                              (.progn (.string= "next") (.identity 1))
                              (.identity 0)))
                 (_ (.optional (.whitespace))))
           (.or (.smart-range (.progn (.string= "year")
                                      (.identity (list (+ (car date-now) offset) nil nil))))
                (.smart-range (.progn (.string= "month")
                                      (.identity (subseq (month-start-date (car date-now) (cadr date-now) offset)
                                                         0 2))))
                (.smart-range (.progn (.string= "week")
                                      (.identity (week-start-date now offset)))
                              (* +day+ 7)))))))

(defun .query-value-period ()
  (.let* ((period (.or (.let* ((start (.optional (.smart-date)))
                               (_ (.optional (.whitespace)))
                               (_ (.or (.char= #\-) (.string= "to")))
                               (_ (.optional (.whitespace)))
                               (end (.optional (.smart-date))))
                         (if (or start end)
                             (.identity (cons (car start) (car end)))
                             (.fail)))
                       (.smart-date))))
    (destructuring-bind (start . end) period
      (.identity #'(lambda (value)
                     (and
                      (or (not start) (>= value start))
                      (or (not end) (< value end))))))))

(defun .query-term ()
  (.or (.query-coloned :acct (.query-postingp "acct" #'posting-account)
                       (.query-value-regex))
       (.query-coloned :amt (.progn (.string= "amt")
                                    (.identity
                                     #'(lambda (e p)
                                         (let ((amounts (get-amounts p (entry-postings e))))
                                           (if (> (length amounts) 1) :t
                                               (amount-quantity (car amounts)))))))
                       (.query-value-amount))
       (.query-coloned :code (.query-entryp "code" #'entry-code)
                       (.query-value-regex))
       (.query-coloned :cur (.progn (.string= "cur")
                                    (.identity
                                     #'(lambda (e p)
                                         (get-amounts p (entry-postings e)))))
                       (.let* ((regexp (.query-value-regex)))
                         (.identity #'(lambda (amounts)
                                        (find-if regexp amounts :key #'amount-commodity)))))
       (.query-coloned :desc (.query-entryp "desc" #'entry-description)
                       (.query-value-regex))
       (.query-coloned :date (.query-entryp "date" #'entry-date)
                       (.query-value-period))
       (.let* ((value (.query-value-regex)))
         (.identity (cons :acct
                          #'(lambda (entry posting)
                              (declare (ignore entry))
                              (let ((account (posting-account posting)))
                                (funcall value account))))))))

(defun .arg ()
  (.let* ((word (.until (.chars #\' #\" #\Space #\Tab) :result-type 'string :at-least 0))
          (quoted (.optional (.let* ((quote (.chars #\' #\"))
                                     (text (.until (.char= quote) :result-type 'string :at-least 0))
                                     (_ (.char= quote)))
                               (.identity text)))))
    (.identity (if quoted (concatenate 'string word quoted)
                   word))))

(defun make-query-predicate (terms)
  (let (desc acct status other)
    (loop for (type . f) in terms
       do (case type
            (:desc (push f desc))
            (:acct (push f acct))
            (:status (push f status))
            (otherwise (push f other))))
    #'(lambda (entry posting)
        (labels ((any (predicates)
                   (or (not predicates)
                       (find-if #'(lambda (p) (funcall p entry posting)) predicates)))
                 (all (predicates)
                   (not (find-if-not #'(lambda (p) (funcall p entry posting)) predicates))))
          (and (any desc) (any acct) (any status) (all other))))))

(defun .query ()
  (.let* ((args (.mapcar* (.prog1 (.arg) (.optional (.whitespace))))))
    (loop for arg in args with terms
       do (multiple-value-bind (pred left)
              (parse (.query-term) arg)
            (if (and pred (input-empty-p left))
                (push pred terms)
                (return (.fail))))
       finally (return (.identity (make-query-predicate terms))))))

(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)
  (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 (apply #'max (mapcar #'length accounts))))
    (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)))))