diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/ldg-mode.el | 5 | ||||
| -rw-r--r-- | lisp/ldg-new.el | 2 | ||||
| -rw-r--r-- | lisp/ldg-occur.el | 252 | ||||
| -rw-r--r-- | lisp/ldg-reconcile.el | 165 |
4 files changed, 348 insertions, 76 deletions
diff --git a/lisp/ldg-mode.el b/lisp/ldg-mode.el index c185c198..4c55cdc0 100644 --- a/lisp/ldg-mode.el +++ b/lisp/ldg-mode.el @@ -72,6 +72,7 @@ customizable to ease retro-entry.") (define-key map [(control ?c) (control ?s)] 'ledger-sort-region) (define-key map [(control ?c) (control ?t)] 'ledger-test-run) (define-key map [(control ?c) (control ?v)] 'ledger-post-edit-amount) + (define-key map [(control ?c) (control ?f)] 'ledger-occur) (define-key map [tab] 'pcomplete) (define-key map [(control ?i)] 'pcomplete) (define-key map [(control ?c) tab] 'ledger-fully-complete-entry) @@ -110,7 +111,9 @@ customizable to ease retro-entry.") (define-key map [delete-xact] '(menu-item "Delete Entry" ledger-delete-current-entry)) (define-key map [add-xact] '(menu-item "Add Entry" ledger-add-entry :enable ledger-works)) (define-key map [sep3] '(menu-item "--")) - (define-key map [reconcile] '(menu-item "Reconcile Account" ledger-reconcile :enable ledger-works)))) + (define-key map [reconcile] '(menu-item "Reconcile Account" ledger-reconcile :enable ledger-works)) + (define-key map [reconcile] '(menu-item "Hide Xacts" ledger-occur)) + )) (defun ledger-time-less-p (t1 t2) "Say whether time value T1 is less than time value T2." diff --git a/lisp/ldg-new.el b/lisp/ldg-new.el index c885cf21..1d7d5cac 100644 --- a/lisp/ldg-new.el +++ b/lisp/ldg-new.el @@ -45,6 +45,8 @@ (require 'ldg-xact) (require 'ldg-sort) (require 'ldg-fonts) +(require 'ldg-occur) + ;(autoload #'ledger-mode "ldg-mode" nil t) ;(autoload #'ledger-fully-complete-entry "ldg-complete" nil t) ;(autoload #'ledger-toggle-current "ldg-state" nil t) 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 diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el index 753c2fa5..0cac33c5 100644 --- a/lisp/ldg-reconcile.el +++ b/lisp/ldg-reconcile.el @@ -24,6 +24,12 @@ (defvar ledger-buf nil) (defvar ledger-acct nil) +(defcustom ledger-fold-on-reconcile t + "if t, limit transactions shown in main buffer to those + matching the reconcile regex" + :group 'ledger) +(make-variable-buffer-local 'ledger-fold-on-reconcilex) + (defun ledger-display-balance () "Calculate the cleared balance of the account being reconciled" (interactive) @@ -55,10 +61,10 @@ (with-current-buffer ledger-buf (goto-char (cdr where)) (setq cleared (ledger-toggle-current-entry))) - ;remove the existing face and add the new face + ;remove the existing face and add the new face (remove-text-properties (line-beginning-position) - (line-end-position) - (list 'face)) + (line-end-position) + (list 'face)) (if cleared (add-text-properties (line-beginning-position) (line-end-position) @@ -72,7 +78,11 @@ (defun ledger-reconcile-new-account (account) (interactive "sAccount to reconcile: ") (set (make-local-variable 'ledger-acct) account) - (ledger-reconcile-refresh)) + (let ((buf (current-buffer))) + (if ledger-fold-on-reconcile + (ledger-occur-change-regex account ledger-buf)) + (set-buffer buf) + (ledger-reconcile-refresh))) (defun ledger-reconcile-refresh () (interactive) @@ -125,7 +135,10 @@ (defun ledger-reconcile-quit () (interactive) - (kill-buffer (current-buffer))) + (let ((buf ledger-buf)) + (kill-buffer (current-buffer)) + (if ledger-fold-on-reconcile + (ledger-occur-quit-buffer buf)))) (defun ledger-reconcile-finish () (interactive) @@ -144,49 +157,49 @@ (defun ledger-do-reconcile () "get the uncleared transactions in the account and display them in the *Reconcile* buffer" - (let* ((buf ledger-buf) + (let* ((buf ledger-buf) (account ledger-acct) (items (with-temp-buffer (ledger-exec-ledger buf (current-buffer) "--uncleared" "--real" - "emacs" account) + "emacs" account) (goto-char (point-min)) (unless (eobp) (unless (looking-at "(") (error (buffer-string))) (read (current-buffer)))))) - (dolist (item items) - (let ((index 1)) - (dolist (xact (nthcdr 5 item)) - (let ((beg (point)) - (where - (with-current-buffer buf - (cons - (nth 0 item) - (if ledger-clear-whole-entries - (save-excursion - (goto-line (nth 1 item)) - (point-marker)) - (save-excursion - (goto-line (nth 0 xact)) - (point-marker))))))) - (insert (format "%s %-4s %-30s %-30s %15s\n" - (format-time-string "%Y/%m/%d" (nth 2 item)) - (if (nth 3 item) - (nth 3 item) - "") - (nth 4 item) (nth 1 xact) (nth 2 xact))) - (if (nth 3 xact) - (set-text-properties beg (1- (point)) - (list 'face 'ledger-font-reconciler-cleared-face - 'where where)) - (set-text-properties beg (1- (point)) - (list 'face 'ledger-font-reconciler-uncleared-face - 'where where)))) - (setq index (1+ index))))) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (toggle-read-only t))) + (dolist (item items) + (let ((index 1)) + (dolist (xact (nthcdr 5 item)) + (let ((beg (point)) + (where + (with-current-buffer buf + (cons + (nth 0 item) + (if ledger-clear-whole-entries + (save-excursion + (goto-line (nth 1 item)) + (point-marker)) + (save-excursion + (goto-line (nth 0 xact)) + (point-marker))))))) + (insert (format "%s %-4s %-30s %-30s %15s\n" + (format-time-string "%Y/%m/%d" (nth 2 item)) + (if (nth 3 item) + (nth 3 item) + "") + (nth 4 item) (nth 1 xact) (nth 2 xact))) + (if (nth 3 xact) + (set-text-properties beg (1- (point)) + (list 'face 'ledger-font-reconciler-cleared-face + 'where where)) + (set-text-properties beg (1- (point)) + (list 'face 'ledger-font-reconciler-uncleared-face + 'where where)))) + (setq index (1+ index))))) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (toggle-read-only t))) (defun ledger-reconcile (account) @@ -196,6 +209,8 @@ (if rbuf (kill-buffer rbuf)) (add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save) + (if ledger-fold-on-reconcile + (ledger-occur-mode account buf)) (with-current-buffer (pop-to-buffer (get-buffer-create "*Reconcile*")) (ledger-reconcile-mode) @@ -206,41 +221,41 @@ (defvar ledger-reconcile-mode-abbrev-table) (define-derived-mode ledger-reconcile-mode text-mode "Reconcile" - "A mode for reconciling ledger entries." - (let ((map (make-sparse-keymap))) - (define-key map [(control ?m)] 'ledger-reconcile-visit) - (define-key map [return] 'ledger-reconcile-visit) - (define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish) - (define-key map [(control ?x) (control ?s)] 'ledger-reconcile-save) - (define-key map [(control ?l)] 'ledger-reconcile-refresh) - (define-key map [? ] 'ledger-reconcile-toggle) - (define-key map [?a] 'ledger-reconcile-add) - (define-key map [?d] 'ledger-reconcile-delete) - (define-key map [?g] 'ledger-reconcile-new-account) - (define-key map [?n] 'next-line) - (define-key map [?p] 'previous-line) - (define-key map [?s] 'ledger-reconcile-save) - (define-key map [?q] 'ledger-reconcile-quit) - (define-key map [?b] 'ledger-display-balance) - - (define-key map [menu-bar] (make-sparse-keymap "ldg-recon-menu")) - (define-key map [menu-bar ldg-recon-menu] (cons "Reconcile" map)) - (define-key map [menu-bar ldg-recon-menu qui] '("Quit" . ledger-reconcile-quit)) - (define-key map [menu-bar ldg-recon-menu sep1] '("--")) - (define-key map [menu-bar ldg-recon-menu pre] '("Previous Entry" . previous-line)) - (define-key map [menu-bar ldg-recon-menu vis] '("Visit Entry" . ledger-reconcile-visit)) - (define-key map [menu-bar ldg-recon-menu nex] '("Next Entry" . next-line)) - (define-key map [menu-bar ldg-recon-menu sep2] '("--")) - (define-key map [menu-bar ldg-recon-menu del] '("Delete Entry" . ledger-reconcile-delete)) - (define-key map [menu-bar ldg-recon-menu add] '("Add Entry" . ledger-reconcile-add)) - (define-key map [menu-bar ldg-recon-menu tog] '("Toggle Entry" . ledger-reconcile-toggle)) - (define-key map [menu-bar ldg-recon-menu sep3] '("--")) - (define-key map [menu-bar ldg-recon-menu bal] '("Show Cleared Balance" . ledger-display-balance)) - (define-key map [menu-bar ldg-recon-menu sep4] '("--")) - (define-key map [menu-bar ldg-recon-menu rna] '("Reconcile New Account" . ledger-reconcile-new-account)) - (define-key map [menu-bar ldg-recon-menu ref] '("Refresh" . ledger-reconcile-refresh)) - (define-key map [menu-bar ldg-recon-menu sav] '("Save" . ledger-reconcile-save)) - - (use-local-map map))) + "A mode for reconciling ledger entries." + (let ((map (make-sparse-keymap))) + (define-key map [(control ?m)] 'ledger-reconcile-visit) + (define-key map [return] 'ledger-reconcile-visit) + (define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish) + (define-key map [(control ?x) (control ?s)] 'ledger-reconcile-save) + (define-key map [(control ?l)] 'ledger-reconcile-refresh) + (define-key map [? ] 'ledger-reconcile-toggle) + (define-key map [?a] 'ledger-reconcile-add) + (define-key map [?d] 'ledger-reconcile-delete) + (define-key map [?g] 'ledger-reconcile-new-account) + (define-key map [?n] 'next-line) + (define-key map [?p] 'previous-line) + (define-key map [?s] 'ledger-reconcile-save) + (define-key map [?q] 'ledger-reconcile-quit) + (define-key map [?b] 'ledger-display-balance) + + (define-key map [menu-bar] (make-sparse-keymap "ldg-recon-menu")) + (define-key map [menu-bar ldg-recon-menu] (cons "Reconcile" map)) + (define-key map [menu-bar ldg-recon-menu qui] '("Quit" . ledger-reconcile-quit)) + (define-key map [menu-bar ldg-recon-menu sep1] '("--")) + (define-key map [menu-bar ldg-recon-menu pre] '("Previous Entry" . previous-line)) + (define-key map [menu-bar ldg-recon-menu vis] '("Visit Entry" . ledger-reconcile-visit)) + (define-key map [menu-bar ldg-recon-menu nex] '("Next Entry" . next-line)) + (define-key map [menu-bar ldg-recon-menu sep2] '("--")) + (define-key map [menu-bar ldg-recon-menu del] '("Delete Entry" . ledger-reconcile-delete)) + (define-key map [menu-bar ldg-recon-menu add] '("Add Entry" . ledger-reconcile-add)) + (define-key map [menu-bar ldg-recon-menu tog] '("Toggle Entry" . ledger-reconcile-toggle)) + (define-key map [menu-bar ldg-recon-menu sep3] '("--")) + (define-key map [menu-bar ldg-recon-menu bal] '("Show Cleared Balance" . ledger-display-balance)) + (define-key map [menu-bar ldg-recon-menu sep4] '("--")) + (define-key map [menu-bar ldg-recon-menu rna] '("Reconcile New Account" . ledger-reconcile-new-account)) + (define-key map [menu-bar ldg-recon-menu ref] '("Refresh" . ledger-reconcile-refresh)) + (define-key map [menu-bar ldg-recon-menu sav] '("Save" . ledger-reconcile-save)) + + (use-local-map map))) (provide 'ldg-reconcile)
\ No newline at end of file |