ledger-occur.el (6897B)
1 ;;; ledger-occur.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org) 4 5 ;; This file is not part of GNU Emacs. 6 7 ;; This is free software; you can redistribute it and/or modify it under 8 ;; the terms of the GNU General Public License as published by the Free 9 ;; Software Foundation; either version 2, or (at your option) any later 10 ;; version. 11 ;; 12 ;; This is distributed in the hope that it will be useful, but WITHOUT 13 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or 14 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15 ;; for more details. 16 ;; 17 ;; You should have received a copy of the GNU General Public License 18 ;; along with GNU Emacs; see the file COPYING. If not, write to the 19 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, 20 ;; MA 02110-1301 USA. 21 22 ;;; Commentary: 23 ;; Provide buffer narrowing to ledger mode. Adapted from original loccur 24 ;; mode by Alexey Veretennikov <alexey dot veretennikov at gmail dot 25 ;; com> 26 ;; 27 ;; Adapted to ledger mode by Craig Earls <enderww at gmail dot 28 ;; com> 29 30 ;;; Code: 31 32 (require 'cl-lib) 33 (require 'ledger-navigate) 34 35 (defconst ledger-occur-overlay-property-name 'ledger-occur-custom-buffer-grep) 36 37 (defcustom ledger-occur-use-face-shown t 38 "If non-nil, use a custom face for xacts shown in `ledger-occur' mode. 39 This uses `ledger-occur-xact-face'." 40 :type 'boolean 41 :group 'ledger) 42 (make-variable-buffer-local 'ledger-occur-use-face-shown) 43 44 45 (defvar ledger-occur-history nil 46 "History of previously searched expressions for the prompt.") 47 48 (defvar-local ledger-occur-current-regex nil 49 "Pattern currently applied to narrow the buffer.") 50 51 (defvar ledger-occur-mode-map 52 (let ((map (make-sparse-keymap))) 53 (define-key map (kbd "C-c C-g") #'ledger-occur-refresh) 54 (define-key map (kbd "C-c C-f") #'ledger-occur-mode) 55 map) 56 "Keymap used by `ledger-occur-mode'.") 57 58 (define-minor-mode ledger-occur-mode 59 "A minor mode which display only transactions matching a pattern. 60 The pattern is given by `ledger-occur-current-regex'." 61 :init-value nil 62 :lighter (:eval (format " Ledger-Narrow(%s)" ledger-occur-current-regex)) 63 :keymap ledger-occur-mode-map 64 (if (and ledger-occur-current-regex ledger-occur-mode) 65 (progn (ledger-occur-refresh) 66 ;; Clear overlays after revert-buffer and similar commands. 67 (add-hook 'change-major-mode-hook #'ledger-occur-remove-overlays nil t)) 68 (ledger-occur-remove-overlays) 69 (message "Showing all transactions"))) 70 71 (defun ledger-occur-refresh () 72 "Re-apply the current narrowing expression." 73 (interactive) 74 (let ((matches (ledger-occur-compress-matches 75 (ledger-occur-find-matches ledger-occur-current-regex)))) 76 (if matches 77 (ledger-occur-create-overlays matches) 78 (message "No matches found for '%s'" ledger-occur-current-regex) 79 (ledger-occur-mode -1)))) 80 81 (defun ledger-occur (regex) 82 "Show only transactions in the current buffer which match REGEX. 83 84 This command hides all xact in the current buffer except those 85 matching REGEX. If REGEX is nil or empty, turn off any narrowing 86 currently active." 87 (interactive 88 (list (read-regexp "Regexp" (ledger-occur-prompt) 'ledger-occur-history))) 89 (if (or (null regex) 90 (zerop (length regex))) ; empty regex, or already have narrowed, clear narrowing 91 (ledger-occur-mode -1) 92 (setq ledger-occur-current-regex regex) 93 (ledger-occur-mode 1))) 94 95 (defun ledger-occur-prompt () 96 "Return the default value of the prompt. 97 98 Default value for prompt is the active region, if it is one line 99 long, otherwise it is the word at point." 100 (if (use-region-p) 101 (let ((pos1 (region-beginning)) 102 (pos2 (region-end))) 103 ;; Check if the start and the of an active region is on 104 ;; the same line 105 (if (= (line-number-at-pos pos1) 106 (line-number-at-pos pos2)) 107 (buffer-substring-no-properties pos1 pos2))) 108 (current-word))) 109 110 111 (defun ledger-occur-make-visible-overlay (beg end) 112 "Make an overlay for a visible portion of the buffer, from BEG to END." 113 (let ((ovl (make-overlay beg end))) 114 (overlay-put ovl ledger-occur-overlay-property-name t) 115 (when ledger-occur-use-face-shown 116 (overlay-put ovl 'font-lock-face 'ledger-occur-xact-face)))) 117 118 (defun ledger-occur-make-invisible-overlay (beg end) 119 "Make an overlay for an invisible portion of the buffer, from BEG to END." 120 (let ((ovl (make-overlay beg end))) 121 (overlay-put ovl ledger-occur-overlay-property-name t) 122 (overlay-put ovl 'invisible t))) 123 124 (defun ledger-occur-create-overlays (ovl-bounds) 125 "Create the overlays for the visible transactions. 126 Argument OVL-BOUNDS contains bounds for the transactions to be left visible." 127 (ledger-occur-remove-overlays) 128 (let ((end-of-last-visible (point-min))) 129 (pcase-dolist (`(,beg ,end) ovl-bounds) 130 ;; keep newline before xact visible, but do not highlight it with 131 ;; `ledger-occur-xact-face' 132 (ledger-occur-make-invisible-overlay end-of-last-visible (1- beg)) 133 (ledger-occur-make-visible-overlay beg end) 134 ;; keep newline after xact visible 135 (setq end-of-last-visible (1+ end))) 136 (ledger-occur-make-invisible-overlay end-of-last-visible (point-max)))) 137 138 (defun ledger-occur-remove-overlays () 139 "Remove the transaction hiding overlays." 140 (interactive) 141 (remove-overlays (point-min) 142 (point-max) ledger-occur-overlay-property-name t)) 143 144 (defun ledger-occur-find-matches (regex) 145 "Return a list of bounds for transactions matching REGEX." 146 (save-excursion 147 (goto-char (point-min)) 148 ;; Set initial values for variables 149 (let (lines) 150 ;; Search loop 151 (while (not (eobp)) 152 ;; if something found 153 (when-let ((endpoint (re-search-forward regex nil 'end)) 154 (bounds (ledger-navigate-find-element-extents endpoint))) 155 (push bounds lines) 156 ;; move to the end of the xact, no need to search inside it more 157 (goto-char (cadr bounds)))) 158 (nreverse lines)))) 159 160 (defun ledger-occur-compress-matches (buffer-matches) 161 "Identify sequential xacts to reduce number of overlays required. 162 163 BUFFER-MATCHES should be a list of (BEG END) lists." 164 (if buffer-matches 165 (let ((points (list)) 166 (current-beginning (caar buffer-matches)) 167 (current-end (cl-cadar buffer-matches))) 168 (dolist (match (cdr buffer-matches)) 169 (if (< (- (car match) current-end) 2) 170 (setq current-end (cadr match)) 171 (push (list current-beginning current-end) points) 172 (setq current-beginning (car match)) 173 (setq current-end (cadr match)))) 174 (nreverse (push (list current-beginning current-end) points))))) 175 176 (provide 'ledger-occur) 177 178 ;;; ledger-occur.el ends here