diff options
Diffstat (limited to 'lisp/ledger-occur.el')
| -rw-r--r-- | lisp/ledger-occur.el | 196 |
1 files changed, 86 insertions, 110 deletions
diff --git a/lisp/ledger-occur.el b/lisp/ledger-occur.el index 33d3a56c..a4fde2e1 100644 --- a/lisp/ledger-occur.el +++ b/lisp/ledger-occur.el @@ -1,6 +1,6 @@ -;;; ledger-mode.el --- Helper code for use with the "ledger" command-line tool +;;; ledger-occur.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, -;; MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: ;; Provide buffer narrowing to ledger mode. Adapted from original loccur @@ -29,6 +29,9 @@ ;;; Code: +(require 'cl) +(require 'ledger-navigate) + (defconst ledger-occur-overlay-property-name 'ledger-occur-custom-buffer-grep) (defcustom ledger-occur-use-face-shown t @@ -38,154 +41,127 @@ (make-variable-buffer-local 'ledger-occur-use-face-shown) -(defvar ledger-occur-mode nil - "name of the minor mode, shown in the mode-line") +(defvar ledger-occur-history nil + "History of previously searched expressions for the prompt.") -(make-variable-buffer-local 'ledger-occur-mode) +(defvar ledger-occur-current-regex nil + "Pattern currently applied to narrow the buffer.") +(make-variable-buffer-local 'ledger-occur-current-regex) -(or (assq 'ledger-occur-mode minor-mode-alist) - (nconc minor-mode-alist - (list '(ledger-occur-mode ledger-occur-mode)))) +(defvar ledger-occur-mode-map (make-sparse-keymap)) -(defvar ledger-occur-history nil - "History of previously searched expressions for the prompt.") +(define-minor-mode ledger-occur-mode + "A minor mode which display only transactions matching `ledger-occur-current-regex'." + nil + (:eval (format " Ledger-Narrow(%s)" ledger-occur-current-regex)) + ledger-occur-mode-map + (if (and ledger-occur-current-regex ledger-occur-mode) + (ledger-occur-refresh) + (ledger-occur-remove-overlays) + (message "Showing all transactions"))) -(defvar ledger-occur-last-match nil - "Last match found.") -(make-variable-buffer-local 'ledger-occur-last-match) +(define-key ledger-occur-mode-map (kbd "C-c C-g") 'ledger-occur-refresh) +(define-key ledger-occur-mode-map (kbd "C-c C-f") 'ledger-occur-mode) -(defun ledger-occur-remove-all-overlays () - "Remove all overlays from the ledger buffer." +(defun ledger-occur-refresh () + "Re-apply the current narrowing expression." (interactive) - (remove-overlays)) - -(defun ledger-occur-mode (regex buffer) - "Highlight transactions that match REGEX in BUFFER, hiding others. - -When REGEX is nil, unhide everything, and remove higlight" - (set-buffer buffer) - (setq ledger-occur-mode - (if (or (null regex) - (zerop (length regex))) - nil - (concat " Ledger-Narrowed: " regex))) - (force-mode-line-update) - (ledger-occur-remove-overlays) - (when ledger-occur-mode - (ledger-occur-create-overlays - (ledger-occur-compress-matches - (ledger-occur-find-matches regex))) - (setq ledger-occur-last-match regex) - (if (get-buffer-window buffer) - (select-window (get-buffer-window buffer)))) - (recenter)) + (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)))) (defun ledger-occur (regex) - "Perform a simple grep in current buffer for the regular expression REGEX. + "Show only transactions in the current buffer which match REGEX. - This command hides all xact from the current buffer except - those containing the regular expression REGEX. A second call - of the function unhides lines again" +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." (interactive - (if ledger-occur-mode - (list nil) - (list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ") - nil 'ledger-occur-history (ledger-occur-prompt))))) - (ledger-occur-mode regex (current-buffer))) + (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))) (defun ledger-occur-prompt () "Return the default value of the prompt. Default value for prompt is a current word or active region(selection), if its size is 1 line" - (let ((prompt - (if (and transient-mark-mode - mark-active) - (let ((pos1 (region-beginning)) - (pos2 (region-end))) - ;; Check if the start and the of an active region is on - ;; the same line - (if (= (line-number-at-pos pos1) - (line-number-at-pos pos2)) - (buffer-substring-no-properties pos1 pos2))) - (current-word)))) - prompt)) + (if (use-region-p) + (let ((pos1 (region-beginning)) + (pos2 (region-end))) + ;; Check if the start and the of an active region is on + ;; the same line + (if (= (line-number-at-pos pos1) + (line-number-at-pos pos2)) + (buffer-substring-no-properties pos1 pos2))) + (current-word))) (defun ledger-occur-make-visible-overlay (beg end) - (let ((ovl (make-overlay beg end (current-buffer)))) - (overlay-put ovl ledger-occur-overlay-property-name t) - (overlay-put ovl 'face 'ledger-occur-xact-face))) + (let ((ovl (make-overlay beg end (current-buffer)))) + (overlay-put ovl ledger-occur-overlay-property-name t) + (overlay-put ovl 'face 'ledger-occur-xact-face))) (defun ledger-occur-make-invisible-overlay (beg end) - (let ((ovl (make-overlay beg end (current-buffer)))) - (overlay-put ovl ledger-occur-overlay-property-name t) - (overlay-put ovl 'invisible t))) + (let ((ovl (make-overlay beg end (current-buffer)))) + (overlay-put ovl ledger-occur-overlay-property-name t) + (overlay-put ovl 'invisible t))) (defun ledger-occur-create-overlays (ovl-bounds) "Create the overlays for the visible transactions. Argument OVL-BOUNDS contains bounds for the transactions to be left visible." - (let* ((beg (caar ovl-bounds)) - (end (cadar ovl-bounds))) - (ledger-occur-make-invisible-overlay (point-min) (1- beg)) - (dolist (visible (cdr ovl-bounds)) - (ledger-occur-make-visible-overlay beg end) - (ledger-occur-make-invisible-overlay (1+ end) (1- (car visible))) - (setq beg (car visible)) - (setq end (cadr visible))) - (ledger-occur-make-invisible-overlay (1+ end) (point-max)))) - -(defun ledger-occur-quit-buffer (buffer) - "Quits hidings transaction in the given BUFFER. -Used for coordinating `ledger-occur' with other buffers, like reconcile." - (set-buffer buffer) - (setq ledger-occur-mode nil) - (force-mode-line-update) - (ledger-occur-remove-overlays) - (recenter)) + (let* ((beg (caar ovl-bounds)) + (end (cadar ovl-bounds))) + (ledger-occur-remove-overlays) + (ledger-occur-make-invisible-overlay (point-min) (1- beg)) + (dolist (visible (cdr ovl-bounds)) + (ledger-occur-make-visible-overlay beg end) + (ledger-occur-make-invisible-overlay (1+ end) (1- (car visible))) + (setq beg (car visible)) + (setq end (cadr visible))) + (ledger-occur-make-invisible-overlay (1+ end) (point-max)))) (defun ledger-occur-remove-overlays () "Remove the transaction hiding overlays." (interactive) (remove-overlays (point-min) - (point-max) ledger-occur-overlay-property-name t) - (setq ledger-occur-overlay-list nil)) + (point-max) ledger-occur-overlay-property-name t)) (defun ledger-occur-find-matches (regex) "Return a list of 2-number tuples describing the beginning and end of transactions meeting REGEX." (save-excursion (goto-char (point-min)) ;; Set initial values for variables - (let (curpoint - endpoint - (lines (list))) + (let (endpoint lines bounds) ;; Search loop (while (not (eobp)) - (setq curpoint (point)) ;; if something found (when (setq endpoint (re-search-forward regex nil 'end)) - (save-excursion - (let ((bounds (ledger-find-xact-extents (match-beginning 0)))) - (push bounds lines) - (setq curpoint (cadr bounds)))) ;; move to the end of - ;; the xact, no need to - ;; search inside it more - (goto-char curpoint)) - (forward-line 1)) - (setq lines (nreverse lines))))) + (setq bounds (ledger-navigate-find-element-extents endpoint)) + (push bounds lines) + ;; move to the end of the xact, no need to search inside it more + (goto-char (cadr bounds)))) + (nreverse lines)))) (defun ledger-occur-compress-matches (buffer-matches) - "identify sequential xacts to reduce number of overlays required" - (let ((points (list)) - (current-beginning (caar buffer-matches)) - (current-end (cadar buffer-matches))) - (dolist (match (cdr buffer-matches)) - (if (< (- (car match) current-end) 2) - (setq current-end (cadr match)) - (push (list current-beginning current-end) points) - (setq current-beginning (car match)) - (setq current-end (cadr match)))) - (nreverse (push (list current-beginning current-end) points)))) + "identify sequential xacts to reduce number of overlays required" + (if buffer-matches + (let ((points (list)) + (current-beginning (caar buffer-matches)) + (current-end (cadar buffer-matches))) + (dolist (match (cdr buffer-matches)) + (if (< (- (car match) current-end) 2) + (setq current-end (cadr match)) + (push (list current-beginning current-end) points) + (setq current-beginning (car match)) + (setq current-end (cadr match)))) + (nreverse (push (list current-beginning current-end) points))))) (provide 'ledger-occur) |