ledger-occur.el 6.3 KB

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