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
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
;;; 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:
(defface ledger-occur-folded-face
`((t :foreground "grey70" :invisible t ))
"Default face for Ledger occur mode hidden transactions"
:group 'ledger-faces)
(defface ledger-occur-xact-face
`((t :background "blue" :weight normal ))
"Default face for Ledger occur mode shown transactions"
:group 'ledger-faces)
(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"
: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)
(progn
(set-buffer buffer)
(setq ledger-occur-mode
(if (or ledger-occur-mode
(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))
(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 ()
"Returns 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)
(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)
(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,
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 ()
(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)
(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-xact-extents (pos)
"return point for beginning of xact and and of xact containing
position. Requires empty line separating xacts"
(interactive "d")
(save-excursion
(goto-char pos)
(let ((end-pos pos)
(beg-pos pos))
(backward-paragraph)
(forward-line)
(beginning-of-line)
(setq beg-pos (point))
(forward-paragraph)
(forward-line -1)
(end-of-line)
(setq end-pos (1+ (point)))
(list beg-pos end-pos))))
(defun ledger-occur-find-matches (regex)
"Returns a list of 2-number tuples, specifying begnning of the
line and end of a line containing matching xact"
(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-occur-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
|
