diff options
Diffstat (limited to 'lisp/ldg-occur.el')
| -rw-r--r-- | lisp/ldg-occur.el | 137 |
1 files changed, 60 insertions, 77 deletions
diff --git a/lisp/ldg-occur.el b/lisp/ldg-occur.el index 3ae1ea17..451ad1a7 100644 --- a/lisp/ldg-occur.el +++ b/lisp/ldg-occur.el @@ -38,8 +38,8 @@ (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-mode nil + "name of the minor mode, shown in the mode-line") (make-variable-buffer-local 'ledger-occur-mode) @@ -49,16 +49,11 @@ (defvar ledger-occur-history nil "History of previously searched expressions for the prompt.") -;;(make-variable-buffer-local 'ledger-occur-history) (defvar ledger-occur-last-match nil "Last match found.") (make-variable-buffer-local 'ledger-occur-last-match) -(defvar ledger-occur-overlay-list nil - "A list of currently active overlays to the ledger buffer.") -(make-variable-buffer-local 'ledger-occur-overlay-list) - (defun ledger-occur-remove-all-overlays () "Remove all overlays from the ledger buffer." (interactive) @@ -70,21 +65,19 @@ 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))) + (if (or (null regex) + (zerop (length regex))) + nil + (concat " Ledger-Narrowed: " regex))) (force-mode-line-update) (ledger-occur-remove-overlays) - (if ledger-occur-mode - (let* ((buffer-matches (ledger-occur-find-matches regex)) - (ovl-bounds (ledger-occur-create-xact-overlay-bounds buffer-matches))) - (setq ledger-occur-overlay-list - (append (ledger-occur-create-xact-overlays ovl-bounds) - (ledger-occur-create-narrowed-overlays buffer-matches))) - (setq ledger-occur-last-match regex) - (if (get-buffer-window buffer) - (select-window (get-buffer-window buffer))))) + (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)) (defun ledger-occur (regex) @@ -96,8 +89,8 @@ When REGEX is nil, unhide everything, and remove higlight" (interactive (if ledger-occur-mode (list nil) - (list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ") - nil 'ledger-occur-history (ledger-occur-prompt))))) + (list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ") + nil 'ledger-occur-history (ledger-occur-prompt))))) (ledger-occur-mode regex (current-buffer))) (defun ledger-occur-prompt () @@ -115,41 +108,32 @@ When REGEX is nil, unhide everything, and remove higlight" (if (= (line-number-at-pos pos1) (line-number-at-pos pos2)) (buffer-substring-no-properties pos1 pos2))) - (current-word)))) + (current-word)))) prompt)) -(defun ledger-occur-create-narrowed-overlays(buffer-matches) - (if buffer-matches - (let ((overlays - (let ((prev-end (point-min))) - (mapcar (lambda (match) - (prog1 - (make-overlay prev-end (car match) - (current-buffer) t nil) - (setq prev-end (1+ (cadr match))))) - buffer-matches)))) - (mapcar (lambda (ovl) - (overlay-put ovl ledger-occur-overlay-property-name t) - (overlay-put ovl 'invisible t)) - (push (make-overlay (cadr (car(last buffer-matches))) - (point-max) - (current-buffer) t nil) overlays))))) - - -(defun ledger-occur-create-xact-overlays (ovl-bounds) - "Create the overlay for the visible transactions. + +(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))) + +(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))) + +(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 ((overlays - (mapcar (lambda (bnd) - (make-overlay (car bnd) - (cadr bnd) - (current-buffer) t nil)) - ovl-bounds))) - (mapcar (lambda (ovl) - (overlay-put ovl ledger-occur-overlay-property-name t) - (if ledger-occur-use-face-shown - (overlay-put ovl 'face 'ledger-occur-xact-face ))) - overlays))) + (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. @@ -164,45 +148,44 @@ Used for coordinating `ledger-occur' with other buffers, like reconcile." "Remove the transaction hiding overlays." (interactive) (remove-overlays (point-min) - (point-max) ledger-occur-overlay-property-name t) + (point-max) ledger-occur-overlay-property-name t) (setq ledger-occur-overlay-list nil)) - -(defun ledger-occur-create-xact-overlay-bounds (buffer-matches) - "Use BUFFER-MATCHES to produce the overlay for the visible transactions." - (let ((prev-end (point-min)) - (overlays (list))) - (when buffer-matches - (mapc (lambda (line) - (push (list (car line) (cadr line)) overlays) - (setq prev-end (cadr line))) - buffer-matches) - (setq overlays (nreverse overlays))))) - - (defun ledger-occur-find-matches (regex) - "Return a list of 2-number tuples describing the beginning and start of transactions meeting 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 (curpoint + endpoint + (lines (list))) ;; 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 + (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))))) +(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)))) (provide 'ldg-occur) |