1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
;;; ledger-mode.el --- Helper code for use with the "ledger" command-line tool
;; Copyright (C) 2003-2014 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., 59 Temple Place - Suite 330, Boston,
;; MA 02111-1307, 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:
(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-mode nil
"name of the minor mode, shown in the mode-line")
(make-variable-buffer-local 'ledger-occur-mode)
(or (assq 'ledger-occur-mode minor-mode-alist)
(nconc minor-mode-alist
(list '(ledger-occur-mode ledger-occur-mode))))
(defvar ledger-occur-history nil
"History of previously searched expressions for the prompt.")
(defvar ledger-occur-last-match nil
"Last match found.")
(make-variable-buffer-local 'ledger-occur-last-match)
(defun ledger-occur-remove-all-overlays ()
"Remove all overlays from the ledger buffer."
(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))
(defun ledger-occur (regex)
"Perform a simple grep in current buffer for the regular expression 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"
(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)))
(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))
(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* ((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))
(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))
(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)))
;; 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)))))
(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 'ledger-occur)
;;; ledger-occur.el ends here
|
