virtual postings, query options --real, --cost and --tree

parsing.lisp

@@ -127,7 +127,7 @@
 
 (defun .account ()
   (.let* ((account (.until (.or (.string= "  ")
-                                (.char= #\Newline)) :result-type 'string)))
+                                (.chars #\) #\] #\Newline)) :result-type 'string)))
     (.identity (strip-space account))))
 
 (defun parse-account (text)
@@ -193,7 +193,9 @@
 (defun .posting ()
   (.let* ((_ (.whitespace))
           (status (.optional (.prog1 (.status) (.optional (.spaces)))))
+          (virtual (.optional (.chars #\[ #\()))
           (account (.account))
+          (_ (.optional (.chars #\] #\))))
           (amount (.optional (.prog2 (.whitespace :at-least 2) (.amount) (.optional (.whitespace)))))
           (unit-price (.optional (.progn (.char= #\@)
                                          (.not (.char= #\@))
@@ -210,6 +212,7 @@
     (if (and unit-price total-price) (.fail)
         (.identity (make-posting
                     :status status
+                    :virtual virtual
                     :account account
                     :amount amount
                     :unit-price unit-price
@@ -397,7 +400,10 @@
                       (or (not end) (< value end))))))))
 
 (defun .query-term ()
-  (.or (.query-coloned :acct (.query-postingp "acct" #'posting-account)
+  (.or (.progn (.string= "--cost") (.identity (cons :cost t)))
+       (.progn (.string= "--tree") (.identity (cons :tree t)))
+       (.progn (.string= "--real") (.identity (cons :real t)))
+       (.query-coloned :acct (.query-postingp "acct" #'posting-account)
                        (.query-value-regex))
        (.query-coloned :amt (.progn (.string= "amt")
                                     (.identity
@@ -437,22 +443,29 @@
     (.identity (if quoted (concatenate 'string word quoted)
                    word))))
 
-(defun make-query-predicate (terms)
-  (let (desc acct status other)
+(defun make-options (terms)
+  (let (desc acct status other cost tree real)
     (loop for (type . f) in terms
        do (case type
             (:desc (push f desc))
             (:comment (push f desc))
             (:acct (push f acct))
             (:status (push f status))
+            (:cost (setf cost f))
+            (:real (setf real f))
+            (:tree (setf tree f))
             (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))))))
+    (list :predicate
+          #'(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))))
+          :cost cost
+          :tree tree
+          :real real)))
 
 (defun .query ()
   (.let* ((args (.mapcar* (.prog1 (.arg) (.optional (.whitespace))))))
@@ -462,4 +475,4 @@
             (if (and pred (input-empty-p left))
                 (push pred terms)
                 (return (.fail))))
-       finally (return (.identity (make-query-predicate terms))))))
+       finally (return (.identity (make-options terms))))))

pta-ledger.lisp

@@ -2,7 +2,7 @@
 
 (defstruct amount quantity commodity)
 (defstruct posting
-  status account amount unit-price total-price comment)
+  status virtual account amount unit-price total-price comment)
 (defstruct entry
   date secondary-date status code description comment postings)
 
@@ -27,10 +27,10 @@
         (:otherwise result)))))
 
 (defun parse-query (query)
-  (let ((predicate (parse (.query) query)))
-    (unless predicate
+  (let ((options (parse (.query) query)))
+    (unless options
       (error "bad query: ~A" query))
-    predicate))
+    options))
 
 (defun get-commodity (amount)
   (let ((com (amount-commodity amount)))
@@ -73,59 +73,84 @@
             (list amount))
         (complement-amounts postings cost))))
 
-(defun entries (journal &optional predicate)
+(defun entries (journal &key predicate real &allow-other-keys)
   (remove-if (lambda (e)
-               (when predicate
-                 (not (some (lambda (p)
-                              (funcall predicate e p))
-                            (entry-postings e)))))
+               (let ((postings (entry-postings e)))
+                 (or (and predicate (not (member nil postings :key #'(lambda (p) (funcall predicate e p)) :test-not #'eql)))
+                     (and real (not (member nil (entry-postings e) :key #'posting-virtual))))))
              (mapcar #'cdr (remove :entry journal :key #'car :test-not #'eql))))
 
-(defun balance (entries &key predicate cost)
+(defun select-postings (entry &key predicate real)
+  (labels ((valid (posting)
+             (and (or (null predicate)
+                      (funcall predicate entry posting))
+                  (or (null real)
+                      (null (posting-virtual posting))))))
+    (remove-if-not #'valid (entry-postings entry))))
+
+(defun account-parents (account &key tree)
+  (append
+   (when tree
+     (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 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)))
+    (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)
-                  (gethash "TOTALS" balance)
-                  (add-amounts! (gethash "TOTALS" balance) amounts))))))))
+                  (add-amounts! (gethash account balance) amounts))))))
+    (when tree
+      (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))))))
+         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)
-  (format-balance (balance (entries journal)
-                           :predicate (when query (parse-query query)))))
+  (format-balance (apply #'balance (entries journal)
+                         (when query (parse-query query)))))
 
-(defun accounts (entries &key predicate)
+(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 (entry-postings entry))
-        (when (or (null predicate)
-                  (funcall predicate entry posting))
-          (setf (gethash (posting-account posting) accounts) t))))))
+      (dolist (posting (select-postings entry :predicate predicate :real real))
+        (setf (gethash (posting-account posting) accounts) t)))))
 
 (defun journal-accounts (journal &optional query)
-  (accounts (entries journal)
-            :predicate (when query (parse-query query))))
+  (apply #'accounts (entries journal)
+         (when query (parse-query query))))
 
 (defun journal-entries (journal &optional query)
-  (entries journal (when query (parse-query query))))
+  (apply #'entries journal (when query (parse-query query))))
 
 (defun journal-print (journal &optional query)
   (mapcar #'render (journal-entries journal query)))