diff options
Diffstat (limited to 'elpa/ledger-mode-20200530.1710/ledger-occur.el')
| -rw-r--r-- | elpa/ledger-mode-20200530.1710/ledger-occur.el | 169 |
1 files changed, 169 insertions, 0 deletions
diff --git a/elpa/ledger-mode-20200530.1710/ledger-occur.el b/elpa/ledger-mode-20200530.1710/ledger-occur.el new file mode 100644 index 0000000..bfd006e --- /dev/null +++ b/elpa/ledger-mode-20200530.1710/ledger-occur.el @@ -0,0 +1,169 @@ +;;; ledger-occur.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*- + +;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org) + +;; This file is not part of GNU Emacs. + +;; This is free software; you can redistribute it and/or modify it under +;; the terms of the GNU General Public License as published by the Free +;; Software Foundation; either version 2, or (at your option) any later +;; version. +;; +;; This is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +;; for more details. +;; +;; 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., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. + +;;; Commentary: +;; Provide buffer narrowing to ledger mode. Adapted from original loccur +;; mode by Alexey Veretennikov <alexey dot veretennikov at gmail dot +;; com> +;; +;; Adapted to ledger mode by Craig Earls <enderww at gmail dot +;; com> + +;;; Code: + +(require 'cl-lib) +(require 'ledger-navigate) + +(defconst ledger-occur-overlay-property-name 'ledger-occur-custom-buffer-grep) + +(defcustom ledger-occur-use-face-shown t + "If non-nil, use a custom face for xacts shown in `ledger-occur' mode using ledger-occur-xact-face." + :type 'boolean + :group 'ledger) +(make-variable-buffer-local 'ledger-occur-use-face-shown) + + +(defvar ledger-occur-history nil + "History of previously searched expressions for the prompt.") + +(defvar ledger-occur-current-regex nil + "Pattern currently applied to narrow the buffer.") +(make-variable-buffer-local 'ledger-occur-current-regex) + +(defvar ledger-occur-mode-map (make-sparse-keymap)) + +(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"))) + +(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-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)))) + +(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." + (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))) + +(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" + (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) + (when ledger-occur-use-face-shown + (overlay-put ovl 'font-lock-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* ((beg (caar ovl-bounds)) + (end (cl-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)) + +(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 (endpoint lines bounds) + ;; Search loop + (while (not (eobp)) + ;; if something found + (when (setq endpoint (re-search-forward regex nil 'end)) + (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" + (if buffer-matches + (let ((points (list)) + (current-beginning (caar buffer-matches)) + (current-end (cl-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) + +;;; ledger-occur.el ends here |