Enh 246 add code folding to ledger mode

Based on loccur.  Hides everything but the xacts that match a regex.  Linked to reconcile mode so that when you reconcile an account on xacts with that account are shown.  Documentation updated

1 files changed, 252 insertions, 0 deletions

diff --git a/lisp/ldg-occur.el b/lisp/ldg-occur.el
new file mode 100644
index 00000000..9cf7f3b1
--- /dev/null
+++ b/lisp/ldg-occur.el
@@ -0,0 +1,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)
+  (save-excursion
+    (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
+      (mapcar (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)
+      (next-line)
+      (beginning-of-line)
+      (setq beg-pos (point))
+      (forward-paragraph)
+      (previous-line)
+      (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