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
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
;;; ldg-mode.el --- Helper code for use with the "ledger" command-line tool
;; Copyright (C) 2003-2013 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 code folding 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-unfolded t
"If non-nil use a custom face for xacts shown in `ledger-occur' mode."
:type 'boolean
:group 'ledger)
(make-variable-buffer-local 'ledger-occur-use-face-unfolded)
(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.")
(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-mode (regex buffer)
"Highlight transactions that match REGEX in BUFFER, hiding others.
When REGEX is nil, unhide everything, and remove higlight"
(progn
(set-buffer buffer)
(setq ledger-occur-mode
(if (or (null regex)
(zerop (length regex)))
nil
(concat " Ledger-Folded: " 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
(ledger-occur-create-xact-overlays ovl-bounds))
(setq ledger-occur-overlay-list
(append ledger-occur-overlay-list
(ledger-occur-create-folded-overlays buffer-matches)))
(setq ledger-occur-last-match regex)
(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)
">: ") "" 'ledger-occur-history ))))
(if (string-equal "" regex) (setq regex (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-create-folded-overlays(buffer-matches)
(if buffer-matches
(let ((overlays
(let ((prev-end (point-min))
(temp (point-max)))
(mapcar (lambda (match)
(progn
(setq temp prev-end) ;; need a swap so that
;; the last form in
;; the lambda is the
;; (make-overlay)
(setq prev-end (1+ (cadr match)))
;; add 1 so that we skip the
;; empty line after the xact
(make-overlay
temp
(car match)
(current-buffer) t nil)))
buffer-matches))))
(mapcar (lambda (ovl)
(overlay-put ovl ledger-occur-overlay-property-name t)
(overlay-put ovl 'invisible t)
(overlay-put ovl 'intangible 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.
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-unfolded
(overlay-put ovl 'face 'ledger-occur-xact-face )))
overlays)))
(defun ledger-occur-change-regex (regex buffer)
"Use this function to programatically change the overlays using REGEX in BUFFER, rather than quitting out and restarting."
(progn
(set-buffer buffer)
(setq ledger-occur-mode nil)
(force-mode-line-update)
(ledger-occur-mode regex buffer)
(recenter)))
(defun ledger-occur-quit-buffer (buffer)
"Quits hidings transaction in the given BUFFER.
Used for coordinating `ledger-occur' with other buffers, like reconcile."
(progn
(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-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."
(save-excursion
(goto-char (point-min))
;; Set initial values for variables
(let ((curpoint nil)
(endpoint nil)
(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)))))
(provide 'ldg-occur)
;;; ldg-occur.el ends here
|
