Add support for live preview of ledger xact output while adding transactions

ledger-exec.el

@@ -114,9 +114,11 @@ otherwise the error output is displayed and an error is raised."
           nil))))) ;;failure
 
 (defun ledger-check-version ()
-  "Verify that ledger works and is modern enough."
+  "Verify that ledger works and is modern enough.
+
+Only runs in buffers visiting files."
   (interactive)
-  (if ledger-mode-should-check-version
+  (if (and buffer-file-name ledger-mode-should-check-version)
       (if (setq ledger-works (ledger-version-greater-p ledger-version-needed))
           (message "Good Ledger Version")
         (message "Bad Ledger Version"))))

ledger-reconcile.el

@@ -331,8 +331,11 @@ Return the number of uncleared xacts found."
 
 When called interactively, prompt for DATE, then XACT."
   (interactive
-   (list (ledger-read-date "Date: ")
-         (read-string "Transaction: " nil 'ledger-minibuffer-history)))
+   (let* ((date (ledger-read-date "Date: "))
+          (xact-text
+           (with-current-buffer ledger-reconcile-ledger-buf
+             (ledger-read-transaction-text date))))
+     (list date xact-text)))
   (with-current-buffer ledger-reconcile-ledger-buf
     (ledger-add-transaction (concat date " " xact)))
   (ledger-reconcile-refresh))

ledger-xact.el

@@ -31,6 +31,7 @@
 (require 'ledger-exec)
 (require 'ledger-post)
 (declare-function ledger-read-date "ledger-mode" (prompt))
+(declare-function ledger-mode "ledger-mode" ())
 
 ;; TODO: This file depends on code in ledger-mode.el, which depends on this.
 
@@ -46,6 +47,15 @@ When nil, `ledger-add-transaction' will not prompt twice."
   :package-version '(ledger-mode . "4.0.1")
   :group 'ledger)
 
+(defcustom ledger-add-transaction-idle-preview t
+  "When non-nil, a live preview of the to-be-added transaction is shown.
+Requires `ledger-add-transaction-prompt-for-text' to be non-nil."
+  :type '(choice (const :tag "Do not preview" nil)
+                 (const :tag "Preview when idle" t)
+                 (number :tag "Preview with custom delay"))
+  :package-version '(ledger-mode . "4.1")
+  :group 'ledger)
+
 (defvar-local ledger-xact-highlight-overlay (list))
 
 (defun ledger-highlight-make-overlay ()
@@ -172,55 +182,202 @@ Leave point on the first amount, if any, otherwise the first account."
 (defvar ledger-add-transaction-last-date nil
   "Last date entered using `ledger-read-transaction'.")
 
+(defvar ledger-xact--preview-buffer-name "*ledger xact preview*")
+(defvar-local ledger-xact--preview-timer nil)
+(defvar-local ledger-xact--date nil
+  "In a minibuffer for the transaction text, the transaction date.")
+(defvar-local ledger-xact--ledger-buf-file nil
+  "In a minibuffer for the transaction text, the input file.
+
+The original ledger buffer is written to this temporary file so it can
+be read by ledger.  This is quite a bit faster than passing in the input
+via `process-send-region'.")
+
+(defun ledger-xact--preview (date args)
+  "Run \"ledger xact\" with DATE and ARGS and display the output.
+
+`ledger-xact--ledger-buf-file' is used as input to \"ledger xact\".
+
+Return the window displaying the output buffer, or nil if it was not
+displayed."
+  (let ((preview-buf
+         (or (get-buffer ledger-xact--preview-buffer-name)
+             (with-current-buffer (get-buffer-create ledger-xact--preview-buffer-name)
+               ;; Enable `ledger-mode' just for syntax highlighting.  Skip all minor
+               ;; modes except for `font-lock-mode'.
+               (delay-mode-hooks (ledger-mode))
+               (font-lock-mode)
+               (setq buffer-read-only t)
+               (set-buffer-modified-p nil)
+               (current-buffer))))
+        (input-file ledger-xact--ledger-buf-file)
+        window)
+    (with-current-buffer preview-buf
+      (with-silent-modifications
+        ;; Don't use `ledger-exec-ledger' because it pops up any error output in
+        ;; a separate buffer.  For this use case, it is preferable to display
+        ;; the error in the preview buffer instead.
+        ;;
+        ;; Also, it uses `call-process-region', which behaves poorly with
+        ;; `while-no-input': if two input events arrive quickly, they may both
+        ;; be lost.  (Try evaluating (while-no-input (call-process "sleep" nil
+        ;; nil nil "10")) and then typing "asdf").
+        ;;
+        ;; Sadly, using `process-send-region' is quite a bit slower than
+        ;; `call-process-region'.
+        ;;
+        ;; TODO: Could we speed up the previews slightly by calling "ledger -f
+        ;; -" (even before the user has begun typing any input) and merely
+        ;; inputting "xact" commands at the REPL when the input changes?
+        (erase-buffer)
+        (while-no-input
+          (unwind-protect
+              (let ((proc (make-process
+                           :name "ledger-xact-preview"
+                           :buffer preview-buf
+                           :command (append (list ledger-binary-path
+                                                  "-f" input-file
+                                                  "xact" date)
+                                            args)
+                           :noquery t
+                           :connection-type 'pipe
+                           :sentinel #'ignore)))
+                (process-send-eof proc)
+                (while (accept-process-output proc)))
+            (when (get-buffer-process preview-buf)
+              (delete-process preview-buf))))
+        (ledger-post-align-postings (point-min) (point-max))))
+    (setq window
+          (display-buffer preview-buf
+                          '((display-buffer-reuse-window display-buffer-at-bottom)
+                            (window-height . fit-window-to-buffer))))
+    ;; modeled after `internal-temp-output-buffer-show'
+    (when window
+      (setq minibuffer-scroll-window window)
+      (set-window-hscroll window 0)
+      (set-window-start window (point-min) t)
+      (set-window-point window (point-min)))
+    window))
+
+(defun ledger-xact--preview-timer (minibuffer)
+  "Preview the ledger xact output from MINIBUFFER's current contents."
+  (setq ledger-xact--preview-timer nil)
+  ;; TODO: It would be more correct to use `minibufferp' and pass a non-nil LIVE
+  ;; argument, but that feature isn't available until Emacs 28.3.
+  (when (and (buffer-live-p minibuffer)
+             (eq minibuffer (window-buffer (active-minibuffer-window))))
+    (with-current-buffer minibuffer
+      (let ((date ledger-xact--date))
+        (when-let* ((args (ledger-parse-transaction-text (minibuffer-contents))))
+          (ledger-xact--preview date args))))))
+
+(defun ledger-xact--after-change-function (_beg _end _len)
+  "Added to `after-change-functions' in transaction-reading minibuffers."
+  (unless ledger-xact--preview-timer
+    (setq ledger-xact--preview-timer
+          (run-with-idle-timer
+           (if (numberp ledger-add-transaction-idle-preview)
+               ledger-add-transaction-idle-preview
+             0.1)
+           nil #'ledger-xact--preview-timer (current-buffer)))))
+
+(defun ledger-xact--hide-preview-window ()
+  "Similar to `minibuffer-restore-windows', for transaction-reading minibuffers."
+  ;; This variable was introduced in Emacs 28.1.  The default, matching the
+  ;; behavior in previous versions of Emacs, is equivalent to non-nil.  We only
+  ;; want to delete the window if the default window configuration restore logic
+  ;; wouldn't have.
+  (when (and (boundp 'read-minibuffer-restore-windows)
+             (not read-minibuffer-restore-windows))
+    (when-let* ((window (get-buffer-window ledger-xact--preview-buffer-name)))
+      (delete-window window))))
+
+(defun ledger-xact--delete-preview-temp-file ()
+  (when ledger-xact--ledger-buf-file
+    (delete-file ledger-xact--ledger-buf-file)))
+
+(defun ledger-read-transaction-text (date)
+  "Read the text of a transaction with date DATE.
+
+The ledger buffer should be current when this function is called, since
+it will be used as input for \"ledger xact\" for the sake of previewing
+output."
+  (let ((ledger-buf (current-buffer))
+        (ledger-buf-dir default-directory))
+    (minibuffer-with-setup-hook
+        (lambda ()
+          (when ledger-add-transaction-idle-preview
+            (setq ledger-xact--date date
+                  ledger-xact--ledger-buf-file
+                  (let* ((temporary-file-directory ledger-buf-dir)
+                         (filename (make-temp-file "ldg-xact-preview" nil ".ldg")))
+                    (with-current-buffer ledger-buf
+                      (save-restriction
+                        (widen)
+                        (write-region nil nil filename nil 'nomessage)))
+                    filename))
+            (add-hook 'after-change-functions #'ledger-xact--after-change-function nil t)
+            (add-hook 'minibuffer-exit-hook #'ledger-xact--hide-preview-window nil t)
+            (add-hook 'minibuffer-exit-hook #'ledger-xact--delete-preview-temp-file nil t)))
+      (read-string (concat "xact " date ": ") nil 'ledger-minibuffer-history))))
+
 (defun ledger-read-transaction ()
   "Read the text of a transaction, which is at least the current date."
   (let ((date (ledger-read-date "Date: ")))
     (concat date " "
             (when ledger-add-transaction-prompt-for-text
-              (read-string (concat "xact " date ": ") nil 'ledger-minibuffer-history)))))
+              (ledger-read-transaction-text date)))))
 
 (defun ledger-parse-iso-date (date)
   "Try to parse DATE using `ledger-iso-date-regexp' and return a time value or nil."
-  (save-match-data
-    (when (string-match ledger-iso-date-regexp date)
-      (encode-time 0 0 0 (string-to-number (match-string 4 date))
-                   (string-to-number (match-string 3 date))
-                   (string-to-number (match-string 2 date))))))
+  (when (string-match ledger-iso-date-regexp date)
+    (encode-time 0 0 0 (string-to-number (match-string 4 date))
+                 (string-to-number (match-string 3 date))
+                 (string-to-number (match-string 2 date)))))
+
+(defun ledger-parse-transaction-text (transaction-text)
+  "Parse TRANSACTION-TEXT as a date and maybe some arguments.
+
+Return (DATE . ARGS), a list of strings."
+  ;; TODO: This whole function could just be replaced with
+  ;; `split-string-shell-command' when the minimum supported Emacs version is
+  ;; Emacs 28.
+  (with-temp-buffer
+    (insert transaction-text)
+    (mapcar #'eval (eshell-parse-arguments (point-min) (point-max)))))
 
 (defun ledger-add-transaction (transaction-text &optional insert-at-point)
   "Use ledger xact TRANSACTION-TEXT to add a transaction to the buffer.
-If INSERT-AT-POINT is non-nil insert the transaction there,
-otherwise call `ledger-xact-find-slot' to insert it at the
-correct chronological place in the buffer.
 
-Interactively, the date is requested via `ledger-read-date' and
-the \\[universal-argument] enables INSERT-AT-POINT."
+If INSERT-AT-POINT is non-nil insert the transaction there, otherwise
+call `ledger-xact-find-slot' to insert it at the correct chronological
+place in the buffer.
+
+Interactively, the date is requested via `ledger-read-date' and the
+\\[universal-argument] enables INSERT-AT-POINT."
   (interactive (list (ledger-read-transaction) current-prefix-arg))
-  (let* ((args (with-temp-buffer
-                 (insert transaction-text)
-                 (eshell-parse-arguments (point-min) (point-max))))
+  (let* ((args (ledger-parse-transaction-text transaction-text))
+         (date (pop args))
          (ledger-buf (current-buffer))
          (separator "\n"))
     (unless insert-at-point
-      (let* ((date (car args))
-             (parsed-date (ledger-parse-iso-date date)))
+      (let* ((parsed-date (ledger-parse-iso-date date)))
         (setq ledger-add-transaction-last-date parsed-date)
         (push-mark)
         ;; TODO: what about when it can't be parsed?
         (ledger-xact-find-slot (or parsed-date date))
         (when (looking-at-p "\n*\\'")
           (setq separator ""))))
-    (if (cdr args)
+    (if args
         (save-excursion
           (insert
            (with-temp-buffer
-             (apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact"
-                    (mapcar 'eval args))
+             (apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact" date args)
              (goto-char (point-min))
              (ledger-post-align-postings (point-min) (point-max))
              (buffer-string))
            separator))
-      (insert (car args) " ")
+      (insert date " ")
       (save-excursion (insert "\n" separator)))))
 
 (provide 'ledger-xact)