|
|
@@ -0,0 +1,537 @@
|
|
|
+(in-package #:pta-ledger)
|
|
|
+
|
|
|
+(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= #\"))))
|
|
|
+
|
|
|
+(defstruct amount quantity commodity)
|
|
|
+
|
|
|
+(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)))))
|
|
|
+
|
|
|
+(defstruct posting
|
|
|
+ status account amount unit-price total-price comment)
|
|
|
+
|
|
|
+(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)))))))))
|
|
|
+
|
|
|
+(defstruct entry
|
|
|
+ date secondary-date status code description comment postings)
|
|
|
+
|
|
|
+(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)))
|
|
|
+
|
|
|
+(defun parse-journal (str)
|
|
|
+ (let ((*default-year* (car (get-date (get-universal-time)))))
|
|
|
+ (parse (.journal) str)))
|
|
|
+
|
|
|
+(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))))))))
|
