split parsing, add rendering

package.lisp

@@ -1,7 +1,26 @@
 (defpackage #:pta-ledger
   (:use #:cl #:smug)
-  (:export #:entry
+  (:export #:amount
+           #:make-amount
+           #:amount-quantity
+           #:amount-commodity
            #:posting
+           #:make-posting
+           #:posting-status
+           #:posting-account
+           #:posting-amount
+           #:posting-unit-price
+           #:posting-total-price
+           #:posting-comment
+           #:entry
+           #:make-entry
+           #:entry-date
+           #:entry-secondary-date
+           #:entry-status
+           #:entry-code
+           #:entry-description
+           #:entry-comment
+           #:entry-postings
            #:parse-journal
            #:parse-query
            #:entries
@@ -10,6 +29,9 @@
            #:journal-balance
            #:journal-failed
            #:parse-error-position
-           #:parse-error-left-data))
+           #:parse-error-left-data
+           #:render
+           #:journal-accounts
+           #:journal-print))
 
 (in-package #:pta-ledger)

parsing.lisp

@@ -0,0 +1,453 @@
+(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 split (text &optional (delimiter (.char= #\Newline)))
+  (when text
+    (parse (.mapcar* (.prog1 (.until delimiter :result-type 'string :at-least 0)
+                             (.optional delimiter))) text)))
+
+(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)))
+
+(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))))))

pta-ledger.asd

@@ -16,5 +16,7 @@
                :smug)
   :serial t
   :components ((:file "package")
+               (:file "parsing")
+               (:file "render")
                (:file "pta-ledger"))
   :description "plain text accounting")

pta-ledger.lisp

@@ -6,269 +6,6 @@
 (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))
@@ -289,190 +26,6 @@
         ((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
@@ -520,8 +73,13 @@
             (list amount))
         (complement-amounts postings cost))))
 
-(defun entries (journal)
-  (mapcar #'cdr (remove :entry journal :key #'car :test-not #'eql)))
+(defun entries (journal &optional predicate)
+  (remove-if (lambda (e)
+               (when predicate
+                 (not (some (lambda (p)
+                              (funcall predicate e p))
+                            (entry-postings e)))))
+             (mapcar #'cdr (remove :entry journal :key #'car :test-not #'eql))))
 
 (defun balance (entries &key predicate cost)
   (let ((balance (make-hash-table :test #'equal)))
@@ -554,3 +112,18 @@
 (defun journal-balance (journal &optional query)
   (format-balance (balance (entries journal)
                            :predicate (when query (parse-query query)))))
+
+(defun accounts (entries &key predicate)
+  (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))))))
+
+(defun journal-accounts (journal &optional query)
+  (accounts (entries journal)
+            :predicate (when query (parse-query query))))
+
+(defun journal-print (journal &optional query)
+  (mapcar #'render (entries journal (when query (parse-query query)))))

render.lisp

@@ -0,0 +1,43 @@
+(in-package #:pta-ledger)
+
+(defun render-date (universal-time)
+  (when universal-time
+    (format nil "~{~4,'0D/~2,'0D/~2,'0D~}" (get-date universal-time))))
+
+(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 account amount unit-price total-price comment) posting
+    (let* ((amount-text (render amount))
+           (status-text (format nil "~@[~A ~]" status))
+           (text (format nil "    ~A~vA~@[  ~A~]~@[ @ ~A~]~@[ @@ ~A~]"
+                         status-text
+                         (if amount-text (- 46 (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)
+                         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))))))