occur: Allow ledger-occur to specify multiple combined filters

ledger-occur.el

@@ -45,52 +45,68 @@ This uses `ledger-occur-xact-face'."
 (defvar ledger-occur-history nil
   "History of previously searched expressions for the prompt.")
 
-(defvar-local ledger-occur-current-regex nil
+(defvar-local ledger-occur-current-regexes nil
   "Pattern currently applied to narrow the buffer.")
 
 (defvar ledger-occur-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map (kbd "C-c C-g") #'ledger-occur-refresh)
-    (define-key map (kbd "C-c C-f") #'ledger-occur-mode)
     map)
   "Keymap used by `ledger-occur-mode'.")
 
 (define-minor-mode ledger-occur-mode
-  "A minor mode which display only transactions matching a pattern.
-The pattern is given by `ledger-occur-current-regex'."
+  "A minor mode which display only transactions matching a list of patterns.
+The patterns are given by `ledger-occur-current-regexes'."
   :init-value nil
-  :lighter (:eval (format " Ledger-Narrow(%s)" ledger-occur-current-regex))
-  :keymap ledger-occur-mode-map
-  (if (and ledger-occur-current-regex ledger-occur-mode)
+  :lighter (:eval (format " Ledger-Narrow(%s)" ledger-occur-current-regexes))
+  (if (and ledger-occur-current-regexes ledger-occur-mode)
       (progn (ledger-occur-refresh)
              ;; Clear overlays after revert-buffer and similar commands.
              (add-hook 'change-major-mode-hook #'ledger-occur-remove-overlays nil t))
+    (setq ledger-occur-current-regexes nil)
     (ledger-occur-remove-overlays)
     (message "Showing all transactions")))
 
 (defun ledger-occur-refresh ()
   "Re-apply the current narrowing expression."
   (interactive)
   (let ((matches (ledger-occur-compress-matches
-                  (ledger-occur-find-matches ledger-occur-current-regex))))
-    (if matches
-        (ledger-occur-create-overlays matches)
-      (message "No matches found for '%s'" ledger-occur-current-regex)
-      (ledger-occur-mode -1))))
+                  (ledger-occur-find-matches ledger-occur-current-regexes))))
+    (ledger-occur-create-overlays matches)
+    (unless matches
+      (message "No matches found for:\n%s\n\n%s"
+               (string-join ledger-occur-current-regexes "\n")
+               (substitute-command-keys "Press \\[universal-argument] \\[ledger-occur] to remove the most recent filter.")))))
 
 (defun ledger-occur (regex)
   "Show only transactions in the current buffer which match REGEX.
 
-This command hides all xact in the current buffer except those
-matching REGEX.  If REGEX is nil or empty, turn off any narrowing
-currently active."
+If filtering is already in effect, further filter the shown
+transactions, so that only transactions which match all of the REGEX
+filters specified so far are displayed.
+
+This command hides all xact in the current buffer except those matching
+REGEX.  If REGEX is the symbol `pop', or a prefix argument has been
+provided interactively, remove the most recently-added REGEX filter
+instead.  If REGEX is nil or empty, or with two prefix arguments, turn
+off any narrowing currently active."
   (interactive
-   (list (read-regexp "Regexp" (ledger-occur-prompt) 'ledger-occur-history)))
-  (if (or (null regex)
-          (zerop (length regex)))  ; empty regex, or already have narrowed, clear narrowing
-      (ledger-occur-mode -1)
-    (setq ledger-occur-current-regex regex)
-    (ledger-occur-mode 1)))
+   (cond
+    ((equal current-prefix-arg '(16)) (list nil))
+    (current-prefix-arg (list 'pop))
+    (t (list (read-regexp "Regexp" (ledger-occur-prompt) 'ledger-occur-history)))))
+  (cond
+   ((eq regex 'pop)
+    (pop ledger-occur-current-regexes)
+    (if ledger-occur-current-regexes
+        (ledger-occur-mode 1)
+      (ledger-occur-mode -1)))
+   ((or (null regex)
+        (zerop (length regex)))  ; empty regex, clear narrowing
+    (ledger-occur-mode -1))
+   (t
+    (push regex ledger-occur-current-regexes)
+    (ledger-occur-mode 1))))
 
 (defun ledger-occur-prompt ()
   "Return the default value of the prompt.
@@ -141,23 +157,36 @@ Argument OVL-BOUNDS contains bounds for the transactions to be left visible."
   (remove-overlays (point-min)
                    (point-max) ledger-occur-overlay-property-name t))
 
-(defun ledger-occur-find-matches (regex)
-  "Return a list of bounds for transactions matching REGEX."
+(defun ledger-occur-find-matches (regexes)
+  "Return a list of bounds for transactions matching REGEXES.
+
+REGEXES must be non-nil.
+
+Only transactions whose bodies match all of the regexps in REGEXES are
+included in the return value.  The occurrences may be in any order."
+  ;; Check the regexes in the order that they were specified by the user.  In
+  ;; some edge cases, this may produce different behavior than without reversing
+  ;; `regexes'.
+  (setq regexes (reverse regexes))
   (save-excursion
     (goto-char (point-min))
-    ;; Set initial values for variables
-    (let (lines)
-      ;; Search loop
+    (let (all-bounds)
       (while (not (eobp))
-        ;; if something found
-        (when-let* ((endpoint (re-search-forward regex nil 'end))
+        ;; if something found, check that the remaining regexes all match
+        (when-let* ((endpoint (re-search-forward (car regexes) nil 'end))
                     (bounds (ledger-navigate-find-element-extents endpoint)))
-          (push bounds lines)
-          ;; Move to the end of the xact, no need to search inside it more.
-          ;; Defensive: if extent end is at or before point, advance past the
-          ;; match end so the loop can never wedge.
-          (goto-char (max (cadr bounds) (1+ (match-end 0))))))
-      (nreverse lines))))
+          (when (cl-every
+                 (lambda (regex)
+                   (save-excursion
+                     (goto-char (car bounds))
+                     (re-search-forward regex (cadr bounds) t)))
+                 (cdr regexes))
+            (push bounds all-bounds)
+            ;; Move to the end of the xact, no need to search inside it more.
+            ;; Defensive: if extent end is at or before point, advance past the
+            ;; match end so the loop can never wedge.
+            (goto-char (max (cadr bounds) (1+ (match-end 0)))))))
+      (nreverse all-bounds))))
 
 (defun ledger-occur-compress-matches (buffer-matches)
   "Identify sequential xacts to reduce number of overlays required.

test/occur-test.el

@@ -124,6 +124,21 @@ https://github.com/ledger/ledger-mode/issues/54"
 
     ;; no matches
     (ledger-occur "zzzzzz")
+    (should (equal (ledger-test-visible-buffer-string) ""))
+
+    ;; remove last filter
+    (ledger-occur 'pop)
+    (should
+     (equal (ledger-test-visible-buffer-string)
+            "\
+
+2024-03-15 Employer
+  * Assets:Checking           $2000.00
+  Income:Salary
+"))
+
+    ;; turn off filtering entirely
+    (ledger-occur nil)
     (should
      (equal (ledger-test-visible-buffer-string)
             "\
@@ -215,12 +230,40 @@ https://github.com/ledger/ledger-mode/issues/415"
   Expenses:Food:Groceries     $50
   Assets:Checking
 "
-    (cl-letf (((symbol-function 'read-regexp)
-               (lambda (&rest _) "Groceries")))
-      (call-interactively #'ledger-occur)
-      (should ledger-occur-mode)
-      (should (equal "Groceries" ledger-occur-current-regex)))))
-
+    (let ((user-inputs '("Groceries" "Checking" "Groceries" "Checking")))
+      (cl-letf (((symbol-function 'read-regexp)
+                 (lambda (&rest _) (pop user-inputs))))
+        (call-interactively #'ledger-occur)
+        (should ledger-occur-mode)
+        (should (equal '("Groceries") ledger-occur-current-regexes))
+
+        ;; second call adds a new filter
+        (call-interactively #'ledger-occur)
+        (should ledger-occur-mode)
+        (should (equal '("Checking" "Groceries") ledger-occur-current-regexes))
+
+        ;; with prefix argument, pops a filter
+        (let ((current-prefix-arg '(4)))
+          (call-interactively #'ledger-occur))
+        (should ledger-occur-mode)
+        (should (equal '("Groceries") ledger-occur-current-regexes))
+
+        (let ((current-prefix-arg '(4)))
+          (call-interactively #'ledger-occur))
+        (should-not ledger-occur-mode)
+        (should (null ledger-occur-current-regexes))
+
+        ;; add both filters back
+        (call-interactively #'ledger-occur)
+        (call-interactively #'ledger-occur)
+        (should (equal '("Checking" "Groceries") ledger-occur-current-regexes))
+        (should ledger-occur-mode)
+
+        ;; double prefix argument removes all filtering
+        (let ((current-prefix-arg '(16)))
+          (call-interactively #'ledger-occur))
+        (should-not ledger-occur-mode)
+        (should (null ledger-occur-current-regexes))))))
 
 (ert-deftest ledger-occur/test-prompt-region ()
   "`ledger-occur-prompt' returns active region when single-line."

test/test-helper.el

@@ -134,7 +134,7 @@ always located at the beginning of buffer."
 (defun ledger-test-visible-buffer-substring (start end)
   "Same as `buffer-substring', but excludes invisible text.
 The two arguments START and END are character positions."
-  (let (str)
+  (let ((str ""))
     (while (< start end)
       (let ((next-pos (next-char-property-change start end)))
         (when (not (invisible-p start))