diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/CMakeLists.txt | 19 | ||||
| -rw-r--r-- | lisp/ledger-commodities.el | 150 | ||||
| -rw-r--r-- | lisp/ledger-complete.el | 228 | ||||
| -rw-r--r-- | lisp/ledger-context.el | 97 | ||||
| -rw-r--r-- | lisp/ledger-exec.el | 72 | ||||
| -rw-r--r-- | lisp/ledger-fontify.el | 199 | ||||
| -rw-r--r-- | lisp/ledger-fonts.el | 220 | ||||
| -rw-r--r-- | lisp/ledger-init.el | 57 | ||||
| -rw-r--r-- | lisp/ledger-mode.el | 407 | ||||
| -rw-r--r-- | lisp/ledger-navigate.el | 168 | ||||
| -rw-r--r-- | lisp/ledger-occur.el | 196 | ||||
| -rw-r--r-- | lisp/ledger-post.el | 245 | ||||
| -rw-r--r-- | lisp/ledger-reconcile.el | 557 | ||||
| -rw-r--r-- | lisp/ledger-regex.el | 406 | ||||
| -rw-r--r-- | lisp/ledger-report.el | 297 | ||||
| -rw-r--r-- | lisp/ledger-schedule.el | 443 | ||||
| -rw-r--r-- | lisp/ledger-sort.el | 107 | ||||
| -rw-r--r-- | lisp/ledger-state.el | 179 | ||||
| -rw-r--r-- | lisp/ledger-test.el | 26 | ||||
| -rw-r--r-- | lisp/ledger-texi.el | 40 | ||||
| -rw-r--r-- | lisp/ledger-xact.el | 168 |
21 files changed, 2462 insertions, 1819 deletions
diff --git a/lisp/CMakeLists.txt b/lisp/CMakeLists.txt index 33fe6f14..9dee2abb 100644 --- a/lisp/CMakeLists.txt +++ b/lisp/CMakeLists.txt @@ -2,9 +2,12 @@ set(EMACS_LISP_SOURCES ledger-commodities.el ledger-complete.el ledger-exec.el + ledger-fontify.el ledger-fonts.el + ledger-fontify.el ledger-init.el ledger-mode.el + ledger-navigate.el ledger-occur.el ledger-post.el ledger-reconcile.el @@ -17,6 +20,9 @@ set(EMACS_LISP_SOURCES ledger-texi.el ledger-xact.el) +set(EMACS_LISP_SOURCES_UNCOMPILABLE + ledger-context.el) + # find emacs and complain if not found find_program(EMACS_EXECUTABLE emacs) @@ -36,7 +42,14 @@ macro(add_emacs_lisp_target el) COMMENT "Creating byte-compiled Emacs lisp ${CMAKE_CURRENT_BINARY_DIR}/${el}c") endmacro(add_emacs_lisp_target el) -if(EMACS_EXECUTABLE) +if (EMACS_EXECUTABLE) + # uncompilable .el files + foreach(el ${EMACS_LISP_SOURCES_UNCOMPILABLE}) + configure_file(${el} ${CMAKE_CURRENT_BINARY_DIR}/${el}) + list(APPEND EMACS_LISP_UNCOMPILABLE ${CMAKE_CURRENT_BINARY_DIR}/${el}) + endforeach() + + # compilable .el files foreach(el ${EMACS_LISP_SOURCES}) add_emacs_lisp_target(${el}) list(APPEND EMACS_LISP_BINARIES ${CMAKE_CURRENT_BINARY_DIR}/${el}c) @@ -45,8 +58,8 @@ if(EMACS_EXECUTABLE) add_custom_target(emacs_lisp_byte_compile ALL DEPENDS ${EMACS_LISP_BINARIES}) # install the byte-compiled emacs-lisp sources - install(FILES ${EMACS_LISP_SOURCES} ${EMACS_LISP_BINARIES} - DESTINATION share/emacs/site-lisp) + install(FILES ${EMACS_LISP_SOURCES} ${EMACS_LISP_BINARIES} ${EMACS_LISP_UNCOMPILABLE} + DESTINATION share/emacs/site-lisp/ledger-mode) endif() ### CMakeLists.txt ends here diff --git a/lisp/ledger-commodities.el b/lisp/ledger-commodities.el index 48d41979..5ffebf3b 100644 --- a/lisp/ledger-commodities.el +++ b/lisp/ledger-commodities.el @@ -1,6 +1,6 @@ ;;; ledger-commodities.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: ;; Helper functions to deal with commoditized numbers. A commoditized @@ -33,114 +33,108 @@ :type 'string :group 'ledger-reconcile) -(defcustom ledger-scale 10000 - "The 10 ^ maximum number of digits you would expect to appear in your reports. -This is a cheap way of getting around floating point silliness in subtraction") - (defun ledger-split-commodity-string (str) "Split a commoditized string, STR, into two parts. Returns a list with (value commodity)." (let ((number-regex (if (assoc "decimal-comma" ledger-environment-alist) - ledger-amount-decimal-comma-regex - ledger-amount-decimal-period-regex))) - (if (> (length str) 0) - (with-temp-buffer - (insert str) - (goto-char (point-min)) - (cond - ((re-search-forward "\"\\(.*\\)\"" nil t) ; look for quoted commodities - (let ((com (delete-and-extract-region - (match-beginning 1) - (match-end 1)))) - (if (re-search-forward - number-regex nil t) - (list - (ledger-string-to-number - (delete-and-extract-region (match-beginning 0) (match-end 0))) - com)))) - ((re-search-forward number-regex nil t) - ;; found a number in the current locale, return it in the - ;; car. Anything left over is annotation, the first - ;; thing should be the commodity, separated by - ;; whitespace, return it in the cdr. I can't think of - ;; any counterexamples - (list - (ledger-string-to-number - (delete-and-extract-region (match-beginning 0) (match-end 0))) - (nth 0 (split-string (buffer-substring-no-properties (point-min) (point-max)))))) - ((re-search-forward "0" nil t) - ;; couldn't find a decimal number, look for a single 0, - ;; indicating account with zero balance - (list 0 ledger-reconcile-default-commodity)))) - ;; nothing found, return 0 - (list 0 ledger-reconcile-default-commodity)))) + ledger-amount-decimal-comma-regex + ledger-amount-decimal-period-regex))) + (if (> (length str) 0) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (cond + ((re-search-forward "\"\\(.*\\)\"" nil t) ; look for quoted commodities + (let ((com (delete-and-extract-region + (match-beginning 1) + (match-end 1)))) + (if (re-search-forward + number-regex nil t) + (list + (ledger-string-to-number + (delete-and-extract-region (match-beginning 0) (match-end 0))) + com)))) + ((re-search-forward number-regex nil t) + ;; found a number in the current locale, return it in the + ;; car. Anything left over is annotation, the first + ;; thing should be the commodity, separated by + ;; whitespace, return it in the cdr. I can't think of + ;; any counterexamples + (list + (ledger-string-to-number + (delete-and-extract-region (match-beginning 0) (match-end 0))) + (nth 0 (split-string (buffer-substring-no-properties (point-min) (point-max)))))) + ((re-search-forward "0" nil t) + ;; couldn't find a decimal number, look for a single 0, + ;; indicating account with zero balance + (list 0 ledger-reconcile-default-commodity)))) + ;; nothing found, return 0 + (list 0 ledger-reconcile-default-commodity)))) (defun ledger-string-balance-to-commoditized-amount (str) "Return a commoditized amount (val, 'comm') from STR." - ; break any balances with multi commodities into a list + ; break any balances with multi commodities into a list (mapcar #'(lambda (st) - (ledger-split-commodity-string st)) - (split-string str "[\n\r]"))) + (ledger-split-commodity-string st)) + (split-string str "[\n\r]"))) (defun -commodity (c1 c2) "Subtract C2 from C1, ensuring their commodities match." (if (string= (cadr c1) (cadr c2)) - ; the scaling below is to get around inexact subtraction results where, for example - ; 1.23 - 4.56 = -3.3299999999999996 instead of -3.33 - (list (/ (- (* ledger-scale (car c1)) (* ledger-scale (car c2))) ledger-scale) (cadr c1)) - (error "Can't subtract different commodities %S from %S" c2 c1))) + (list (-(car c1) (car c2)) (cadr c1)) + (error "Can't subtract different commodities %S from %S" c2 c1))) (defun +commodity (c1 c2) "Add C1 and C2, ensuring their commodities match." (if (string= (cadr c1) (cadr c2)) (list (+ (car c1) (car c2)) (cadr c1)) - (error "Can't add different commodities, %S to %S" c1 c2))) + (error "Can't add different commodities, %S to %S" c1 c2))) (defun ledger-strip (str char) - (let (new-str) - (concat (dolist (ch (append str nil) new-str) - (unless (= ch char) - (setq new-str (append new-str (list ch)))))))) + "Return STR with CHAR removed." + (replace-regexp-in-string char "" str)) (defun ledger-string-to-number (str &optional decimal-comma) - "improve builtin string-to-number by handling internationalization, and return nil if number can't be parsed" - (let ((nstr (if (or decimal-comma - (assoc "decimal-comma" ledger-environment-alist)) - (ledger-strip str ?.) - (ledger-strip str ?,)))) - (while (string-match "," nstr) ;if there is a comma now, it is a thousands separator - (setq nstr (replace-match "." nil nil nstr))) - (string-to-number nstr))) + "improve builtin string-to-number by handling internationalization, and return nil if number can't be parsed" + (let ((nstr (if (or decimal-comma + (assoc "decimal-comma" ledger-environment-alist)) + (ledger-strip str ".") + (ledger-strip str ",")))) + (while (string-match "," nstr) ;if there is a comma now, it is a thousands separator + (setq nstr (replace-match "." nil nil nstr))) + (string-to-number nstr))) (defun ledger-number-to-string (n &optional decimal-comma) - (let ((str (number-to-string n))) - (if (or decimal-comma - (assoc "decimal-comma" ledger-environment-alist)) - (while (string-match "\\." str) - (setq str (replace-match "," nil nil str))) - str))) + "number-to-string that handles comma as decimal." + (let ((str (number-to-string n))) + (when (or decimal-comma + (assoc "decimal-comma" ledger-environment-alist)) + (while (string-match "\\." str) + (setq str (replace-match "," nil nil str)))) + str)) (defun ledger-commodity-to-string (c1) "Return string representing C1. Single character commodities are placed ahead of the value, longer ones are after the value." - (let ((str (ledger-number-to-string (car c1))) - (commodity (cadr c1))) - (if (> (length commodity) 1) - (concat str " " commodity) + (let ((str (ledger-number-to-string (car c1))) + (commodity (cadr c1))) + (if (> (length commodity) 1) + (concat str " " commodity) (concat commodity " " str)))) (defun ledger-read-commodity-string (prompt) + "Read an amount from mini-buffer using PROMPT." (let ((str (read-from-minibuffer - (concat prompt " (" ledger-reconcile-default-commodity "): "))) - comm) + (concat prompt " (" ledger-reconcile-default-commodity "): "))) + comm) (if (and (> (length str) 0) - (ledger-split-commodity-string str)) - (progn - (setq comm (ledger-split-commodity-string str)) - (if (cadr comm) - comm - (list (car comm) ledger-reconcile-default-commodity)))))) + (ledger-split-commodity-string str)) + (progn + (setq comm (ledger-split-commodity-string str)) + (if (cadr comm) + comm + (list (car comm) ledger-reconcile-default-commodity)))))) (provide 'ledger-commodities) diff --git a/lisp/ledger-complete.el b/lisp/ledger-complete.el index a8ef9a8a..2fae9911 100644 --- a/lisp/ledger-complete.el +++ b/lisp/ledger-complete.el @@ -1,6 +1,6 @@ ;;; ledger-complete.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: ;; Functions providing payee and account auto complete. @@ -34,8 +34,8 @@ ;; with pcomplete. See pcomplete-parse-arguments-function for ;; details (let* ((begin (save-excursion - (ledger-thing-at-point) ;; leave point at beginning of thing under point - (point))) + (ledger-thing-at-point) ;; leave point at beginning of thing under point + (point))) (end (point)) begins args) ;; to support end of line metadata @@ -65,57 +65,42 @@ (unless (and (>= origin (match-beginning 0)) (< origin (match-end 0))) (setq payees-list (cons (match-string-no-properties 3) - payees-list))))) ;; add the payee - ;; to the list + payees-list))))) ;; add the payee + ;; to the list (pcomplete-uniqify-list (nreverse payees-list)))) (defun ledger-find-accounts-in-buffer () - (interactive) - (let ((origin (point)) - accounts - (account-tree (list t)) - (account-elements nil) - (seed-regex (ledger-account-any-status-with-seed-regex - (regexp-quote (car pcomplete-args))))) - (save-excursion - (goto-char (point-min)) - - (dolist (account - (delete-dups - (progn - (while (re-search-forward seed-regex nil t) - (unless (between origin (match-beginning 0) (match-end 0)) - (setq accounts (cons (match-string-no-properties 2) accounts)))) - accounts))) - (let ((root account-tree)) - (setq account-elements - (split-string - account ":")) - (while account-elements - (let ((xact (assoc (car account-elements) root))) - (if xact - (setq root (cdr xact)) - (setq xact (cons (car account-elements) (list t))) - (nconc root (list xact)) - (setq root (cdr xact)))) - (setq account-elements (cdr account-elements)))))) - account-tree)) - -(defun ledger-find-metadata-in-buffer () - "Search through buffer and build list of metadata. -Return list." - (let ((origin (point)) accounts) + (interactive) + (let ((origin (point)) + accounts + (account-tree (list t)) + (account-elements nil) + (seed-regex (ledger-account-any-status-with-seed-regex + (regexp-quote (car pcomplete-args))))) (save-excursion - (setq ledger-account-tree (list t)) (goto-char (point-min)) - (while (re-search-forward - ledger-metadata-regex - nil t) - (unless (and (>= origin (match-beginning 0)) - (< origin (match-end 0))) - (setq accounts (cons (match-string-no-properties 2) accounts))))) - accounts)) + + (dolist (account + (delete-dups + (progn + (while (re-search-forward seed-regex nil t) + (unless (between origin (match-beginning 0) (match-end 0)) + (setq accounts (cons (match-string-no-properties 2) accounts)))) + accounts))) + (let ((root account-tree)) + (setq account-elements + (split-string + account ":")) + (while account-elements + (let ((xact (assoc (car account-elements) root))) + (if xact + (setq root (cdr xact)) + (setq xact (cons (car account-elements) (list t))) + (nconc root (list xact)) + (setq root (cdr xact)))) + (setq account-elements (cdr account-elements)))))) + account-tree)) (defun ledger-accounts () "Return a tree of all accounts in the buffer." @@ -129,19 +114,19 @@ Return list." (setq prefix (concat prefix (and prefix ":") (car elements)) root (cdr xact)) - (setq root nil elements nil))) + (setq root nil elements nil))) (setq elements (cdr elements))) (setq root (delete (list (car elements) t) root)) (and root (sort (mapcar (function (lambda (x) - (let ((term (if prefix - (concat prefix ":" (car x)) - (car x)))) - (if (> (length (cdr x)) 1) - (concat term ":") - term)))) + (let ((term (if prefix + (concat prefix ":" (car x)) + (car x)))) + (if (> (length (cdr x)) 1) + (concat term ":") + term)))) (cdr root)) 'string-lessp)))) @@ -155,39 +140,42 @@ Return list." (delete (caar (ledger-parse-arguments)) (ledger-payees-in-buffer)) ;; this completes against payee names - (progn - (let ((text (buffer-substring-no-properties - (line-beginning-position) - (line-end-position)))) - (delete-region (line-beginning-position) - (line-end-position)) - (condition-case nil - (ledger-add-transaction text t) - (error nil))) - (forward-line) - (goto-char (line-end-position)) - (search-backward ";" (line-beginning-position) t) - (skip-chars-backward " \t0123456789.,") - (throw 'pcompleted t))) - (ledger-accounts))))) + (progn + (let ((text (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)))) + (delete-region (line-beginning-position) + (line-end-position)) + (condition-case nil + (ledger-add-transaction text t) + (error nil))) + (forward-line) + (goto-char (line-end-position)) + (search-backward ";" (line-beginning-position) t) + (skip-chars-backward " \t0123456789.,") + (throw 'pcompleted t))) + (ledger-accounts))))) + +(defun ledger-trim-trailing-whitespace (str) + (replace-regexp-in-string "[ \t]*$" "" str)) (defun ledger-fully-complete-xact () "Completes a transaction if there is another matching payee in the buffer. Does not use ledger xact" (interactive) - (let* ((name (caar (ledger-parse-arguments))) - (rest-of-name name) - xacts) + (let* ((name (ledger-trim-trailing-whitespace (caar (ledger-parse-arguments)))) + (rest-of-name name) + xacts) (save-excursion (when (eq 'transaction (ledger-thing-at-point)) - (delete-region (point) (+ (length name) (point))) - ;; Search backward for a matching payee + (delete-region (point) (+ (length name) (point))) + ;; Search backward for a matching payee (when (re-search-backward (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*" (regexp-quote name) ".*\\)" ) nil t) - (setq rest-of-name (match-string 3)) + (setq rest-of-name (match-string 3)) ;; Start copying the postings - (forward-line) + (forward-line) (while (looking-at ledger-account-any-status-regex) (setq xacts (cons (buffer-substring-no-properties (line-beginning-position) @@ -198,7 +186,7 @@ Does not use ledger xact" ;; Insert rest-of-name and the postings (when xacts (save-excursion - (insert rest-of-name ?\n) + (insert rest-of-name ?\n) (while xacts (insert (car xacts) ?\n) (setq xacts (cdr xacts)))) @@ -208,49 +196,55 @@ Does not use ledger xact" (goto-char (match-end 0)))))) +(defcustom ledger-complete-ignore-case t + "Non-nil means that ledger-complete-at-point will be case-insensitive" + :type 'boolean + :group 'ledger) + (defun ledger-pcomplete (&optional interactively) "Complete rip-off of pcomplete from pcomplete.el, only added ledger-magic-tab in the previous commands list so that ledger-magic-tab would cycle properly" (interactive "p") - (if (and interactively - pcomplete-cycle-completions - pcomplete-current-completions - (memq last-command '(ledger-magic-tab - ledger-pcomplete - pcomplete-expand-and-complete - pcomplete-reverse))) - (progn - (delete-backward-char pcomplete-last-completion-length) - (if (eq this-command 'pcomplete-reverse) - (progn - (push (car (last pcomplete-current-completions)) - pcomplete-current-completions) - (setcdr (last pcomplete-current-completions 2) nil)) - (nconc pcomplete-current-completions - (list (car pcomplete-current-completions))) - (setq pcomplete-current-completions - (cdr pcomplete-current-completions))) - (pcomplete-insert-entry pcomplete-last-completion-stub - (car pcomplete-current-completions) - nil pcomplete-last-completion-raw)) - (setq pcomplete-current-completions nil - pcomplete-last-completion-raw nil) - (catch 'pcompleted - (let* ((pcomplete-stub) - pcomplete-seen pcomplete-norm-func - pcomplete-args pcomplete-last pcomplete-index - (pcomplete-autolist pcomplete-autolist) - (pcomplete-suffix-list pcomplete-suffix-list) + (let ((pcomplete-ignore-case ledger-complete-ignore-case)) + (if (and interactively + pcomplete-cycle-completions + pcomplete-current-completions + (memq last-command '(ledger-magic-tab + ledger-pcomplete + pcomplete-expand-and-complete + pcomplete-reverse))) + (progn + (delete-char (* -1 pcomplete-last-completion-length)) + (if (eq this-command 'pcomplete-reverse) + (progn + (push (car (last pcomplete-current-completions)) + pcomplete-current-completions) + (setcdr (last pcomplete-current-completions 2) nil)) + (nconc pcomplete-current-completions + (list (car pcomplete-current-completions))) + (setq pcomplete-current-completions + (cdr pcomplete-current-completions))) + (pcomplete-insert-entry pcomplete-last-completion-stub + (car pcomplete-current-completions) + nil pcomplete-last-completion-raw)) + (setq pcomplete-current-completions nil + pcomplete-last-completion-raw nil) + (catch 'pcompleted + (let* (pcomplete-stub + pcomplete-seen pcomplete-norm-func + pcomplete-args pcomplete-last pcomplete-index + pcomplete-autolist (completions (pcomplete-completions)) - (result (pcomplete-do-complete pcomplete-stub completions))) - (and result - (not (eq (car result) 'listed)) - (cdr result) - (pcomplete-insert-entry pcomplete-stub (cdr result) - (memq (car result) - '(sole shortest)) - pcomplete-last-completion-raw)))))) + (result (pcomplete-do-complete pcomplete-stub completions)) + (pcomplete-termination-string "")) + (and result + (not (eq (car result) 'listed)) + (cdr result) + (pcomplete-insert-entry pcomplete-stub (cdr result) + (memq (car result) + '(sole shortest)) + pcomplete-last-completion-raw))))))) (provide 'ledger-complete) diff --git a/lisp/ledger-context.el b/lisp/ledger-context.el index b1bcd870..0dfa4645 100644 --- a/lisp/ledger-context.el +++ b/lisp/ledger-context.el @@ -1,6 +1,6 @@ ;;; ledger-context.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: @@ -28,56 +28,45 @@ (eval-when-compile (require 'cl)) -;; *-string constants are assembled in the single-line-config macro to -;; form the regex and list of elements -(defconst indent-string "\\(^[ \t]+\\)") -(defconst status-string "\\([*! ]?\\)") -(defconst account-string "[\\[(]?\\(.*?\\)[])]?") -(defconst amount-string "[ \t]?\\(-?[0-9]+\\.[0-9]*\\)") -(defconst comment-string "[ \t]*;[ \t]*\\(.*?\\)") -(defconst nil-string "\\([ \t]+\\)") -(defconst commodity-string "\\(.+?\\)") -(defconst date-string "^\\([0-9]\\{4\\}[/-][01]?[0-9][/-][0123]?[0-9]\\)") -(defconst code-string "\\((.*)\\)?") -(defconst payee-string "\\(.*\\)") - -(defmacro line-regex (&rest elements) - (let (regex-string) - (concat (dolist (e elements regex-string) - (setq regex-string - (concat regex-string - (eval - (intern - (concat (symbol-name e) "-string")))))) "[ \t]*$"))) - -(defmacro single-line-config2 (&rest elements) -"Take list of ELEMENTS and return regex and element list for use in context-at-point" - (let (regex-string) - `'(,(concat (dolist (e elements regex-string) - (setq regex-string - (concat regex-string - (eval - (intern - (concat (symbol-name e) "-string")))))) "[ \t]*$") - ,elements))) - -(defmacro single-line-config (&rest elements) +;; ledger-*-string constants are assembled in the +;; `ledger-single-line-config' macro to form the regex and list of +;; elements +(defconst ledger-indent-string "\\(^[ \t]+\\)") +(defconst ledger-status-string "\\([*! ]?\\)") +(defconst ledger-account-string "[\\[(]?\\(.*?\\)[])]?") +(defconst ledger-separator-string "\\s-\\s-") +(defconst ledger-amount-string "\\(-?[0-9]+[\\.,][0-9]*\\)") +(defconst ledger-comment-string "[ \t]*;[ \t]*\\(.*?\\)") +(defconst ledger-nil-string "\\([ \t]\\)") +(defconst ledger-commodity-string "\\(.+?\\)") +(defconst ledger-date-string "^\\([0-9]\\{4\\}[/-][01]?[0-9][/-][0123]?[0-9]\\)") +(defconst ledger-code-string "\\((.*)\\)?") +(defconst ledger-payee-string "\\(.*\\)") + +(defun ledger-get-regex-str (name) + "Get the ledger regex of type NAME." + (symbol-value (intern (concat "ledger-" (symbol-name name) "-string")))) + +(defun ledger-line-regex (elements) + "Get a regex to match ELEMENTS on a single line." + (concat (apply 'concat (mapcar 'ledger-get-regex-str elements)) "[ \t]*$")) + +(defmacro ledger-single-line-config (&rest elements) "Take list of ELEMENTS and return regex and element list for use in context-at-point" - `'(,(eval `(line-regex ,@elements)) - ,elements)) + `(list (ledger-line-regex (quote ,elements)) (quote ,elements))) (defconst ledger-line-config - (list (list 'xact (list (single-line-config date nil status nil code nil payee nil comment) - (single-line-config date nil status nil code nil payee) - (single-line-config date nil status nil payee))) - (list 'acct-transaction (list (single-line-config indent comment) - (single-line-config2 indent status account nil commodity amount nil comment) - (single-line-config2 indent status account nil commodity amount) - (single-line-config2 indent status account nil amount nil commodity comment) - (single-line-config2 indent status account nil amount nil commodity) - (single-line-config2 indent status account nil amount) - (single-line-config2 indent status account nil comment) - (single-line-config2 indent status account))))) + (list (list 'xact (list (ledger-single-line-config date nil status nil code nil payee nil comment) + (ledger-single-line-config date nil status nil code nil payee) + (ledger-single-line-config date nil status nil payee))) + (list 'acct-transaction (list (ledger-single-line-config indent comment) + (ledger-single-line-config indent status account separator commodity amount nil comment) + (ledger-single-line-config indent status account separator commodity amount) + (ledger-single-line-config indent status account separator amount nil commodity comment) + (ledger-single-line-config indent status account separator amount nil commodity) + (ledger-single-line-config indent status account separator amount) + (ledger-single-line-config indent status account separator comment) + (ledger-single-line-config indent status account))))) (defun ledger-extract-context-info (line-type pos) "Get context info for current line with LINE-TYPE. @@ -111,9 +100,9 @@ Leave point at the beginning of the thing under point" (let ((here (point))) (goto-char (line-beginning-position)) (cond ((looking-at "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.+?)\\)?\\s-+") - (goto-char (match-end 0)) + (goto-char (match-end 0)) 'transaction) - ((looking-at "^\\s-+\\([*!]\\s-+\\)?[[(]?\\(.\\)") + ((looking-at "^\\s-+\\([*!]\\s-+\\)?[[(]?\\([^\\s-]\\)") (goto-char (match-beginning 2)) 'posting) ((looking-at "^\\(sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat\\)\\s-+") @@ -176,7 +165,7 @@ specified line, returns nil." (let ((left (forward-line offset))) (if (not (equal left 0)) nil - (ledger-context-at-point))))) + (ledger-context-at-point))))) (defun ledger-context-line-type (context-info) (nth 0 context-info)) @@ -208,4 +197,4 @@ specified line, returns nil." (provide 'ledger-context) -;;; ledger-report.el ends here +;;; ledger-context.el ends here diff --git a/lisp/ledger-exec.el b/lisp/ledger-exec.el index 95b28ec2..8902d839 100644 --- a/lisp/ledger-exec.el +++ b/lisp/ledger-exec.el @@ -1,6 +1,6 @@ ;;; ledger-exec.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: @@ -36,9 +36,9 @@ :group 'ledger) (defcustom ledger-mode-should-check-version t - "Should Ledger-mode verify that the executable is working" - :type 'boolean - :group 'ledger-exec) + "Should Ledger-mode verify that the executable is working?" + :type 'boolean + :group 'ledger-exec) (defcustom ledger-binary-path "ledger" "Path to the ledger executable." @@ -53,29 +53,30 @@ (setq buffer-read-only t))) (defun ledger-exec-success-p (ledger-output-buffer) + "Return t if the ledger output in LEDGER-OUTPUT-BUFFER is successful." (with-current-buffer ledger-output-buffer (goto-char (point-min)) (if (and (> (buffer-size) 1) (looking-at (regexp-quote "While"))) - nil ;; failure, there is an error starting with "While" - ledger-output-buffer))) + nil ;; failure, there is an error starting with "While" + ledger-output-buffer))) (defun ledger-exec-ledger (input-buffer &optional output-buffer &rest args) "Run Ledger using INPUT-BUFFER and optionally capturing output in OUTPUT-BUFFER with ARGS." (if (null ledger-binary-path) (error "The variable `ledger-binary-path' has not been set") - (let ((buf (or input-buffer (current-buffer))) - (outbuf (or output-buffer - (generate-new-buffer " *ledger-tmp*")))) - (with-current-buffer buf - (let ((coding-system-for-write 'utf-8) - (coding-system-for-read 'utf-8)) - (apply #'call-process-region - (append (list (point-min) (point-max) - ledger-binary-path nil outbuf nil "-f" "-") - args))) - (if (ledger-exec-success-p outbuf) - outbuf - (ledger-exec-handle-error outbuf)))))) + (let ((buf (or input-buffer (current-buffer))) + (outbuf (or output-buffer + (generate-new-buffer " *ledger-tmp*")))) + (with-current-buffer buf + (let ((coding-system-for-write 'utf-8) + (coding-system-for-read 'utf-8)) + (apply #'call-process-region + (append (list (point-min) (point-max) + ledger-binary-path nil outbuf nil "-f" "-") + args))) + (if (ledger-exec-success-p outbuf) + outbuf + (ledger-exec-handle-error outbuf)))))) (defun ledger-version-greater-p (needed) "Verify the ledger binary is usable for `ledger-mode' (version greater than NEEDED)." @@ -83,25 +84,24 @@ (version-strings '())) (with-temp-buffer (when (ledger-exec-ledger (current-buffer) (current-buffer) "--version") - (goto-char (point-min)) - (delete-horizontal-space) - (setq version-strings (split-string - (buffer-substring-no-properties (point) - (point-max)))) - (if (and (string-match (regexp-quote "Ledger") (car version-strings)) - (or (string= needed (cadr version-strings)) - (string< needed (cadr version-strings)))) - t ;; success - nil))))) ;;failure + (goto-char (point-min)) + (delete-horizontal-space) + (setq version-strings (split-string + (buffer-substring-no-properties (point) + (point-max)))) + (if (and (string-match (regexp-quote "Ledger") (car version-strings)) + (or (string= needed (cadr version-strings)) + (string< needed (cadr version-strings)))) + t ;; success + nil))))) ;;failure (defun ledger-check-version () "Verify that ledger works and is modern enough." (interactive) - (if ledger-mode-should-check-version - (if (setq ledger-works (ledger-version-greater-p ledger-version-needed)) - (message "Good Ledger Version") - (message "Bad Ledger Version")) - setq ledger-works t)) + (if ledger-mode-should-check-version + (if (setq ledger-works (ledger-version-greater-p ledger-version-needed)) + (message "Good Ledger Version") + (message "Bad Ledger Version")))) (provide 'ledger-exec) diff --git a/lisp/ledger-fontify.el b/lisp/ledger-fontify.el new file mode 100644 index 00000000..d307208f --- /dev/null +++ b/lisp/ledger-fontify.el @@ -0,0 +1,199 @@ +;;; ledger-fontify.el --- Provide custom fontification for ledger-mode + + +;; Copyright (C) 2014 Craig P. Earls (enderw88 at gmail dot com) + +;; 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., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. + +;;; Commentary: +;; Font-lock-mode doesn't handle multiline syntax very well. This +;; code provides font lock that is sensitive to overall transaction +;; states + + +;;; Code: + +(require 'ledger-navigate) +(require 'ledger-regex) +(require 'ledger-state) + +(defcustom ledger-fontify-xact-state-overrides nil + "If t the highlight entire xact with state." + :type 'boolean + :group 'ledger) + +(defun ledger-fontify-buffer-part (&optional beg end len) +"Fontify buffer from BEG to END, length LEN." + (save-excursion + (unless beg (setq beg (point-min))) + (unless end (setq end (point-max))) + (beginning-of-line) + (while (< (point) end) + (cond ((or (looking-at ledger-xact-start-regex) + (looking-at ledger-posting-regex)) + (ledger-fontify-xact-at (point))) + ((looking-at ledger-directive-start-regex) + (ledger-fontify-directive-at (point)))) + (ledger-navigate-next-xact-or-directive)))) + +(defun ledger-fontify-xact-at (position) + "Fontify the xact at POSITION." + (interactive "d") + (save-excursion + (goto-char position) + (let ((extents (ledger-navigate-find-element-extents position)) + (state (ledger-transaction-state))) + (if (and ledger-fontify-xact-state-overrides state) + (cond ((eq state 'cleared) + (ledger-fontify-set-face extents 'ledger-font-xact-cleared-face)) + ((eq state 'pending) + (ledger-fontify-set-face extents 'ledger-font-xact-pending-face))) + (ledger-fontify-xact-by-line extents))))) + +(defun ledger-fontify-xact-by-line (extents) + "Do line-by-line detailed fontification of xact in EXTENTS." + (save-excursion + (ledger-fontify-xact-start (car extents)) + (while (< (point) (cadr extents)) + (if (looking-at "[ \t]+;") + (ledger-fontify-set-face (list (point) (progn + (end-of-line) + (point))) 'ledger-font-comment-face) + (ledger-fontify-posting (point))) + (forward-line)))) + +(defun ledger-fontify-xact-start (pos) + "POS should be at the beginning of a line starting an xact. +Fontify the first line of an xact" + (goto-char pos) + (let ((line-start (line-beginning-position))) + (goto-char line-start) + (re-search-forward "[ \t]") + (ledger-fontify-set-face (list line-start (match-beginning 0)) 'ledger-font-posting-date-face) + (goto-char line-start) + (re-search-forward ledger-xact-after-date-regex) + (let ((state (save-match-data (ledger-state-from-string (match-string 1))))) + (ledger-fontify-set-face (list (match-beginning 3) (match-end 3)) + (cond ((eq state 'pending) + 'ledger-font-payee-pending-face) + ((eq state 'cleared) + 'ledger-font-payee-cleared-face) + (t + 'ledger-font-payee-uncleared-face)))) + (when (match-beginning 4) + (ledger-fontify-set-face (list (match-beginning 4) + (match-end 4)) 'ledger-font-comment-face)) + (forward-line))) + +(defun ledger-fontify-posting (pos) + "Fontify the posting at POS." + (let* ((state nil) + (end-of-line-comment nil) + (end (progn (end-of-line) + (point))) + (start (progn (beginning-of-line) + (point)))) + + ;; Look for a posting status flag + (set-match-data nil 'reseat) + (re-search-forward " \\([*!]\\) " end t) + (if (match-string 1) + (setq state (ledger-state-from-string (match-string 1)))) + (beginning-of-line) + (re-search-forward "[[:graph:]]\\([ \t][ \t]\\)" end 'end) ;; find the end of the account, or end of line + + (when (<= (point) end) ;; we are still on the line + (ledger-fontify-set-face (list start (point)) + (cond ((eq state 'cleared) + 'ledger-font-posting-account-cleared-face) + ((eq state 'pending) + 'ledger-font-posting-account-pending-face) + (t + 'ledger-font-posting-account-face))) + + + (when (< (point) end) ;; there is still more to fontify + (setq start (point)) ;; update start of next font region + (setq end-of-line-comment (re-search-forward ";" end 'end)) ;; find the end of the line, or start of a comment + (ledger-fontify-set-face (list start (point) ) + (cond ((eq state 'cleared) + 'ledger-font-posting-amount-cleared-face) + ((eq state 'pending) + 'ledger-font-posting-amount-pending-face) + (t + 'ledger-font-posting-amount-face))) + (when end-of-line-comment + (setq start (point)) + (end-of-line) + (ledger-fontify-set-face (list (- start 1) (point)) ;; subtract 1 from start because we passed the semi-colon + 'ledger-font-comment-face)))))) + +(defun ledger-fontify-directive-at (pos) + "Fontify the directive at POS." + (let ((extents (ledger-navigate-find-element-extents pos)) + (face 'ledger-font-default-face)) + (cond ((looking-at "=") + (setq face 'ledger-font-auto-xact-face)) + ((looking-at "~") + (setq face 'ledger-font-periodic-xact-face)) + ((looking-at "[;#%|\\*]") + (setq face 'ledger-font-comment-face)) + ((looking-at "\\(year\\)\\|Y") + (setq face 'ledger-font-year-directive-face)) + ((looking-at "account") + (setq face 'ledger-font-account-directive-face)) + ((looking-at "apply") + (setq face 'ledger-font-apply-directive-face)) + ((looking-at "alias") + (setq face 'ledger-font-alias-directive-face)) + ((looking-at "assert") + (setq face 'ledger-font-assert-directive-face)) + ((looking-at "\\(bucket\\)\\|A") + (setq face 'ledger-font-bucket-directive-face)) + ((looking-at "capture") + (setq face 'ledger-font-capture-directive-face)) + ((looking-at "check") + (setq face 'ledger-font-check-directive-face)) + ((looking-at "commodity") + (setq face 'ledger-font-commodity-directive-face)) + ((looking-at "define") + (setq face 'ledger-font-define-directive-face)) + ((looking-at "end") + (setq face 'ledger-font-end-directive-face)) + ((looking-at "expr") + (setq face 'ledger-font-expr-directive-face)) + ((looking-at "fixed") + (setq face 'ledger-font-fixed-directive-face)) + ((looking-at "include") + (setq face 'ledger-font-include-directive-face)) + ((looking-at "payee") + (setq face 'ledger-font-payee-directive-face)) + ((looking-at "P") + (setq face 'ledger-font-price-directive-face)) + ((looking-at "tag") + (setq face 'ledger-font-tag-directive-face))) + (ledger-fontify-set-face extents face))) + +(defun ledger-fontify-set-face (extents face) + "Set the text in EXTENTS to FACE." + (put-text-property (car extents) (cadr extents) 'face face)) + + +(provide 'ledger-fontify) + +;;; ledger-fontify.el ends here diff --git a/lisp/ledger-fonts.el b/lisp/ledger-fonts.el index 28f1f98d..8bdecdb3 100644 --- a/lisp/ledger-fonts.el +++ b/lisp/ledger-fonts.el @@ -1,6 +1,6 @@ ;;; ledger-fonts.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. @@ -29,108 +29,246 @@ (require 'ledger-regex) (defgroup ledger-faces nil "Ledger mode highlighting" :group 'ledger) + +(defface ledger-font-default-face + `((t :inherit default)) + "Default face" + :group 'ledger-faces) + +(defface ledger-font-auto-xact-face + `((t :foreground "orange" :weight normal)) + "Default face for automatic transactions" + :group 'ledger-faces) + +(defface ledger-font-periodic-xact-face + `((t :foreground "green" :weight normal)) + "Default face for automatic transactions" + :group 'ledger-faces) + +(defface ledger-font-xact-cleared-face + `((t :foreground "#AAAAAA" :weight normal)) + "Default face for cleared transaction" + :group 'ledger-faces) + +(defface ledger-font-xact-pending-face + `((t :foreground "#444444" :weight normal)) + "Default face for pending transaction" + :group 'ledger-faces) + +(defface ledger-font-xact-open-face + `((t :foreground "#000000" :weight normal)) + "Default face for transaction under point" + :group 'ledger-faces) + (defface ledger-font-payee-uncleared-face - `((t :foreground "#dc322f" :weight bold )) + `((t :foreground "#dc322f" :weight bold )) "Default face for Ledger" :group 'ledger-faces) (defface ledger-font-payee-cleared-face - `((t :foreground "#657b83" :weight normal )) - "Default face for cleared (*) transactions" + `((t :inherit ledger-font-other-face)) + "Default face for cleared (*) payees" + :group 'ledger-faces) + +(defface ledger-font-payee-pending-face + `((t :foreground "#F24B61" :weight normal)) + "Default face for pending (!) payees" :group 'ledger-faces) (defface ledger-font-xact-highlight-face - `((t :background "#eee8d5")) + `((t :inherit ledger-occur-xact-face)) "Default face for transaction under point" :group 'ledger-faces) (defface ledger-font-pending-face - `((t :foreground "#cb4b16" :weight normal )) + `((t :foreground "#cb4b16" :weight normal )) "Default face for pending (!) transactions" :group 'ledger-faces) (defface ledger-font-other-face - `((t :foreground "#657b83" )) + `((t :foreground "#657b83" :weight normal)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-directive-face + `((t :inherit font-lock-preprocessor-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-account-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-price-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-apply-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-alias-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-assert-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-bucket-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-capture-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-check-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-commodity-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-define-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-end-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-expr-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-fixed-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-include-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-payee-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-tag-directive-face + `((t :inherit ledger-font-directive-face)) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-year-directive-face + `((t :inherit ledger-font-directive-face)) "Default face for other transactions" :group 'ledger-faces) (defface ledger-font-posting-account-face - `((t :foreground "#268bd2" )) + `((t :foreground "#268bd2" )) "Face for Ledger accounts" :group 'ledger-faces) (defface ledger-font-posting-account-cleared-face - `((t :foreground "#657b83" )) + `((t :inherit ledger-font-other-face)) + "Face for Ledger accounts" + :group 'ledger-faces) + +(defface ledger-font-posting-amount-cleared-face + `((t :inherit ledger-font-posting-account-cleared-face)) "Face for Ledger accounts" :group 'ledger-faces) (defface ledger-font-posting-account-pending-face - `((t :foreground "#cb4b16" )) + `((t :inherit ledger-font-pending-face)) + "Face for Ledger accounts" + :group 'ledger-faces) + +(defface ledger-font-posting-amount-pending-face + `((t :inherit ledger-font-posting-account-pending-face)) "Face for Ledger accounts" :group 'ledger-faces) (defface ledger-font-posting-amount-face - `((t :foreground "#cb4b16" )) + `((t :foreground "#cb4b16" )) "Face for Ledger amounts" :group 'ledger-faces) +(defface ledger-font-posting-date-face + `((t :foreground "#cb4b16" )) + "Face for Ledger dates" + :group 'ledger-faces) + (defface ledger-occur-narrowed-face - `((t :foreground "grey70" :invisible t )) + `((t :inherit font-lock-comment-face :invisible t)) "Default face for Ledger occur mode hidden transactions" :group 'ledger-faces) (defface ledger-occur-xact-face - `((t :background "#eee8d5" )) + `((t :inherit highlight)) "Default face for Ledger occur mode shown transactions" :group 'ledger-faces) (defface ledger-font-comment-face - `((t :foreground "#93a1a1" :slant italic)) + `((t :inherit font-lock-comment-face)) "Face for Ledger comments" :group 'ledger-faces) (defface ledger-font-reconciler-uncleared-face - `((t :foreground "#dc322f" :weight bold )) + `((t :inherit ledger-font-payee-uncleared-face)) "Default face for uncleared transactions in the reconcile window" :group 'ledger-faces) (defface ledger-font-reconciler-cleared-face - `((t :foreground "#657b83" :weight normal )) + `((t :inherit ledger-font-other-face)) "Default face for cleared (*) transactions in the reconcile window" :group 'ledger-faces) (defface ledger-font-reconciler-pending-face - `((t :foreground "#cb4b16" :weight normal )) + `((t :inherit ledger-font-pending-face)) "Default face for pending (!) transactions in the reconcile window" :group 'ledger-faces) (defface ledger-font-report-clickable-face - `((t :foreground "#cb4b16" :weight normal )) + `((t :foreground "#cb4b16" :weight normal )) "Default face for pending (!) transactions in the reconcile window" :group 'ledger-faces) + (defvar ledger-font-lock-keywords + `(("account" . ledger-font-account-directive-face) + ("apply" . ledger-font-apply-directive-face) + ("alias" . ledger-font-alias-directive-face) + ("assert" . ledger-font-assert-directive-face) + ("bucket" . ledger-font-bucket-directive-face) + ("capture" . ledger-font-capture-directive-face) + ("check" . ledger-font-check-directive-face) + ("commodity" . ledger-font-commodity-directive-face) + ("define" . ledger-font-define-directive-face) + ("end" . ledger-font-end-directive-face) + ("expr" . ledger-font-expr-directive-face) + ("fixed" . ledger-font-fixed-directive-face) + ("include" . ledger-font-include-directive-face) + ("payee" . ledger-font-payee-directive-face) + ("tag" . ledger-font-tag-directive-face) + ("year" . ledger-font-year-directive-face)) + "Expressions to highlight in Ledger mode.") -(defvar ledger-font-lock-keywords - `( ;; (,ledger-other-entries-regex 1 - ;; ledger-font-other-face) - (,ledger-comment-regex 0 - 'ledger-font-comment-face) - (,ledger-multiline-comment-regex 0 'ledger-font-comment-face) - (,ledger-payee-pending-regex 2 - 'ledger-font-payee-pending-face) ; Works - (,ledger-payee-cleared-regex 2 - 'ledger-font-payee-cleared-face) ; Works - (,ledger-payee-uncleared-regex 2 - 'ledger-font-payee-uncleared-face) ; Works - (,ledger-account-cleared-regex 2 - 'ledger-font-posting-account-cleared-face) ; Works - (,ledger-account-pending-regex 2 - 'ledger-font-posting-account-pending-face) ; Works - (,ledger-account-any-status-regex 2 - 'ledger-font-posting-account-face) ; Works - (,ledger-other-entries-regex 1 - 'ledger-font-other-face)) - "Expressions to highlight in Ledger mode.") (provide 'ledger-fonts) diff --git a/lisp/ledger-init.el b/lisp/ledger-init.el index fd06d4c5..49d74098 100644 --- a/lisp/ledger-init.el +++ b/lisp/ledger-init.el @@ -1,6 +1,6 @@ ;;; ledger-init.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,52 +16,59 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: ;; Determine the ledger environment (require 'ledger-regex) +;;; Code: + (defcustom ledger-init-file-name "~/.ledgerrc" - "Location of the ledger initialization file. nil if you don't have one" + "Location of the ledger initialization file. nil if you don't have one." :group 'ledger-exec) (defvar ledger-environment-alist nil) +(defvar ledger-default-date-format "%Y/%m/%d") + (defun ledger-init-parse-initialization (buffer) + "Parse the .ledgerrc file in BUFFER." (with-current-buffer buffer (let (environment-alist) (goto-char (point-min)) (while (re-search-forward ledger-init-string-regex nil t ) - (let ((matchb (match-beginning 0)) ;; save the match data, string-match stamp on it - (matche (match-end 0))) - (end-of-line) - (setq environment-alist - (append environment-alist - (list (cons (let ((flag (buffer-substring-no-properties (+ 2 matchb) matche))) - (if (string-match "[ \t\n\r]+\\'" flag) - (replace-match "" t t flag) - flag)) - (let ((value (buffer-substring-no-properties matche (point) ))) - (if (> (length value) 0) - value - t)))))))) + (let ((matchb (match-beginning 0)) ;; save the match data, string-match stamp on it + (matche (match-end 0))) + (end-of-line) + (setq environment-alist + (append environment-alist + (list (cons (let ((flag (buffer-substring-no-properties (+ 2 matchb) matche))) + (if (string-match "[ \t\n\r]+\\'" flag) + (replace-match "" t t flag) + flag)) + (let ((value (buffer-substring-no-properties matche (point) ))) + (if (> (length value) 0) + value + t)))))))) environment-alist))) (defun ledger-init-load-init-file () + "Load and parse the .ledgerrc file." (interactive) (let ((init-base-name (file-name-nondirectory ledger-init-file-name))) (if (get-buffer init-base-name) ;; init file already loaded, parse it and leave it - (ledger-init-parse-initialization init-base-name) - (when (and ledger-init-file-name - (file-exists-p ledger-init-file-name) - (file-readable-p ledger-init-file-name)) - (find-file-noselect ledger-init-file-name) - (setq ledger-environment-alist - (ledger-init-parse-initialization init-base-name)) - (kill-buffer init-base-name))))) + (setq ledger-environment-alist + (ledger-init-parse-initialization init-base-name)) + (when (and ledger-init-file-name + (file-exists-p ledger-init-file-name) + (file-readable-p ledger-init-file-name)) + (find-file-noselect ledger-init-file-name) + (setq ledger-environment-alist + (ledger-init-parse-initialization init-base-name)) + (kill-buffer init-base-name))))) (provide 'ledger-init) diff --git a/lisp/ledger-mode.el b/lisp/ledger-mode.el index b604581c..4e2beff6 100644 --- a/lisp/ledger-mode.el +++ b/lisp/ledger-mode.el @@ -1,6 +1,6 @@ ;;; ledger-mode.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. @@ -27,14 +27,18 @@ ;;; Code: (require 'ledger-regex) +(require 'cus-edit) (require 'esh-util) (require 'esh-arg) +(require 'easymenu) (require 'ledger-commodities) (require 'ledger-complete) (require 'ledger-context) (require 'ledger-exec) (require 'ledger-fonts) +(require 'ledger-fontify) (require 'ledger-init) +(require 'ledger-navigate) (require 'ledger-occur) (require 'ledger-post) (require 'ledger-reconcile) @@ -58,29 +62,32 @@ (defconst ledger-mode-version "3.0.0") (defun ledger-mode-dump-variable (var) - (if var - (insert (format " %s: %S\n" (symbol-name var) (eval var))))) + "Format VAR for dump to buffer." + (if var + (insert (format " %s: %S\n" (symbol-name var) (eval var))))) (defun ledger-mode-dump-group (group) - "Dump GROUP customizations to current buffer" + "Dump GROUP customizations to current buffer." (let ((members (custom-group-members group nil))) (dolist (member members) (cond ((eq (cadr member) 'custom-group) - (insert (format "Group %s:\n" (symbol-name (car member)))) - (ledger-mode-dump-group (car member))) - ((eq (cadr member) 'custom-variable) - (ledger-mode-dump-variable (car member))))))) + (insert (format "Group %s:\n" (symbol-name (car member)))) + (ledger-mode-dump-group (car member))) + ((eq (cadr member) 'custom-variable) + (ledger-mode-dump-variable (car member))))))) (defun ledger-mode-dump-configuration () - "Dump all customizations" + "Dump all customizations." + (interactive) (find-file "ledger-mode-dump") (ledger-mode-dump-group 'ledger)) -(defsubst ledger-current-year () +(defun ledger-current-year () "The default current year for adding transactions." (format-time-string "%Y")) -(defsubst ledger-current-month () + +(defun ledger-current-month () "The default current month for adding transactions." (format-time-string "%m")) @@ -91,32 +98,44 @@ "Start a ledger session with the current month, but make it customizable to ease retro-entry.") (defun ledger-read-account-with-prompt (prompt) - (let* ((context (ledger-context-at-point)) - (default (if (and (eq (ledger-context-line-type context) 'acct-transaction) - (eq (ledger-context-current-field context) 'account)) - (regexp-quote (ledger-context-field-value context 'account)) - nil))) - (ledger-read-string-with-default prompt default))) + "Read an account from the minibuffer with PROMPT." + (let ((context (ledger-context-at-point))) + (ledger-read-string-with-default prompt + (if (eq (ledger-context-current-field context) 'account) + (regexp-quote (ledger-context-field-value context 'account)) + nil)))) + +(defun ledger-read-date (prompt) + "Return user-supplied date after `PROMPT', defaults to today." + (let* ((default (ledger-year-and-month)) + (date (read-string prompt default + 'ledger-minibuffer-history))) + (if (or (string= date default) + (string= "" date)) + (format-time-string + (or (cdr (assoc "date-format" ledger-environment-alist)) + ledger-default-date-format)) + date))) (defun ledger-read-string-with-default (prompt default) "Return user supplied string after PROMPT, or DEFAULT." (read-string (concat prompt - (if default - (concat " (" default "): ") - ": ")) - nil 'ledger-minibuffer-history default)) + (if default + (concat " (" default "): ") + ": ")) + nil 'ledger-minibuffer-history default)) (defun ledger-display-balance-at-point () "Display the cleared-or-pending balance. And calculate the target-delta of the account being reconciled." (interactive) (let* ((account (ledger-read-account-with-prompt "Account balance to show")) - (buffer (current-buffer)) - (balance (with-temp-buffer - (ledger-exec-ledger buffer (current-buffer) "cleared" account) - (if (> (buffer-size) 0) - (buffer-substring-no-properties (point-min) (1- (point-max))) - (concat account " is empty."))))) + (buffer (current-buffer)) + (balance (with-temp-buffer + (ledger-exec-ledger buffer (current-buffer) "cleared" account) + (if (> (buffer-size) 0) + (buffer-substring-no-properties (point-min) (1- (point-max))) + (concat account " is empty."))))) (when balance (message balance)))) @@ -125,171 +144,229 @@ And calculate the target-delta of the account being reconciled." And calculate the target-delta of the account being reconciled." (interactive) (let* ((buffer (current-buffer)) - (balance (with-temp-buffer - (ledger-exec-ledger buffer (current-buffer) "stats") - (buffer-substring-no-properties (point-min) (1- (point-max)))))) + (balance (with-temp-buffer + (ledger-exec-ledger buffer (current-buffer) "stats") + (buffer-substring-no-properties (point-min) (1- (point-max)))))) (when balance (message balance)))) (defun ledger-magic-tab (&optional interactively) - "Decide what to with with <TAB>. + "Decide what to with with <TAB>, INTERACTIVELY. Can indent, complete or align depending on context." (interactive "p") - (if (= (point) (line-beginning-position)) - (indent-to ledger-post-account-alignment-column) - (if (and (> (point) 1) - (looking-back "\\([^ \t]\\)" 1)) - (ledger-pcomplete interactively) - (ledger-post-align-postings)))) + (if (= (point) (line-beginning-position)) + (indent-to ledger-post-account-alignment-column) + (if (and (> (point) 1) + (looking-back "\\([^ \t]\\)" 1)) + (ledger-pcomplete interactively) + (ledger-post-align-postings)))) (defvar ledger-mode-abbrev-table) -(defun ledger-insert-effective-date () +(defvar ledger-date-string-today + (format-time-string (or + (cdr (assoc "date-format" ledger-environment-alist)) + ledger-default-date-format))) + +(defun ledger-remove-effective-date () + "Remove the effective date from a transaction or posting." (interactive) - (let ((context (car (ledger-context-at-point))) - (date-string (format-time-string (cdr (assoc "date-format" ledger-environment-alist))))) - (cond ((eq 'xact context) - (beginning-of-line) - (insert date-string "=")) - ((eq 'acct-transaction context) - (end-of-line) - (insert " ; [=" date-string "]"))))) + (let ((context (car (ledger-context-at-point)))) + (save-excursion + (save-restriction + (narrow-to-region (point-at-bol) (point-at-eol)) + (beginning-of-line) + (cond ((eq 'xact context) + (re-search-forward ledger-iso-date-regexp) + (when (= (char-after) ?=) + (let ((eq-pos (point))) + (delete-region + eq-pos + (re-search-forward ledger-iso-date-regexp))))) + ((eq 'acct-transaction context) + ;; Match "; [=date]" & delete string + (when (re-search-forward + (concat ledger-comment-regex + "\\[=" ledger-iso-date-regexp "\\]") + nil 'noerr) + (replace-match "")))))))) + +(defun ledger-insert-effective-date (&optional date) + "Insert effective date `DATE' to the transaction or posting. + +If `DATE' is nil, prompt the user a date. + +Replace the current effective date if there's one in the same +line. + +With a prefix argument, remove the effective date." + (interactive) + (if (and (listp current-prefix-arg) + (= 4 (prefix-numeric-value current-prefix-arg))) + (ledger-remove-effective-date) + (let* ((context (car (ledger-context-at-point))) + (date-string (or date (ledger-read-date "Effective date: ")))) + (save-restriction + (narrow-to-region (point-at-bol) (point-at-eol)) + (cond + ((eq 'xact context) + (beginning-of-line) + (re-search-forward ledger-iso-date-regexp) + (when (= (char-after) ?=) + (ledger-remove-effective-date)) + (insert "=" date-string)) + ((eq 'acct-transaction context) + (end-of-line) + (ledger-remove-effective-date) + (insert " ; [=" date-string "]"))))))) (defun ledger-mode-remove-extra-lines () + "Get rid of multiple empty lines." (goto-char (point-min)) - (while (re-search-forward "\n\n\\(\n\\)+" nil t) - (replace-match "\n\n"))) + (while (re-search-forward "\n\n\\(\n\\)+" nil t) + (replace-match "\n\n"))) (defun ledger-mode-clean-buffer () - "indent, remove multiple linfe feeds and sort the buffer" - (interactive) - (ledger-sort-buffer) - (ledger-post-align-postings (point-min) (point-max)) - (ledger-mode-remove-extra-lines)) - + "Indent, remove multiple line feeds and sort the buffer." + (interactive) + (let ((start (point-min-marker)) + (end (point-max-marker))) + (goto-char start) + (ledger-navigate-beginning-of-xact) + (beginning-of-line) + (let ((target (buffer-substring (point) (progn + (end-of-line) + (point))))) + (untabify start end) + (ledger-sort-buffer) + (ledger-post-align-postings start end) + (ledger-mode-remove-extra-lines) + (goto-char start) + (search-forward target)))) + +(defvar ledger-mode-syntax-table + (let ((table (make-syntax-table text-mode-syntax-table))) + (modify-syntax-entry ?\; "<" table) + (modify-syntax-entry ?\n ">" table) + table) + "Syntax table in use in `ledger-mode' buffers.") + +(defvar ledger-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?c) (control ?a)] 'ledger-add-transaction) + (define-key map [(control ?c) (control ?b)] 'ledger-post-edit-amount) + (define-key map [(control ?c) (control ?c)] 'ledger-toggle-current) + (define-key map [(control ?c) (control ?d)] 'ledger-delete-current-transaction) + (define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-transaction) + (define-key map [(control ?c) (control ?f)] 'ledger-occur) + (define-key map [(control ?c) (control ?k)] 'ledger-copy-transaction-at-point) + (define-key map [(control ?c) (control ?m)] 'ledger-set-month) + (define-key map [(control ?c) (control ?r)] 'ledger-reconcile) + (define-key map [(control ?c) (control ?s)] 'ledger-sort-region) + (define-key map [(control ?c) (control ?t)] 'ledger-insert-effective-date) + (define-key map [(control ?c) (control ?u)] 'ledger-schedule-upcoming) + (define-key map [(control ?c) (control ?y)] 'ledger-set-year) + (define-key map [(control ?c) (control ?p)] 'ledger-display-balance-at-point) + (define-key map [(control ?c) (control ?l)] 'ledger-display-ledger-stats) + (define-key map [(control ?c) (control ?q)] 'ledger-post-align-xact) + + (define-key map [tab] 'ledger-magic-tab) + (define-key map [(control tab)] 'ledger-post-align-xact) + (define-key map [(control ?i)] 'ledger-magic-tab) + (define-key map [(control ?c) tab] 'ledger-fully-complete-xact) + (define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-xact) + + (define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo) + (define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit) + (define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto) + (define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill) + (define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report) + (define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save) + + (define-key map [(meta ?p)] 'ledger-navigate-prev-xact-or-directive) + (define-key map [(meta ?n)] 'ledger-navigate-next-xact-or-directive) + map) + "Keymap for `ledger-mode'.") + +(easy-menu-define ledger-mode-menu ledger-mode-map + "Ledger menu" + '("Ledger" + ["Narrow to REGEX" ledger-occur] + ["Show all transactions" ledger-occur-mode ledger-occur-mode] + ["Ledger Statistics" ledger-display-ledger-stats ledger-works] + "---" + ["Show upcoming transactions" ledger-schedule-upcoming] + ["Add Transaction (ledger xact)" ledger-add-transaction ledger-works] + ["Complete Transaction" ledger-fully-complete-xact] + ["Delete Transaction" ledger-delete-current-transaction] + "---" + ["Calc on Amount" ledger-post-edit-amount] + "---" + ["Check Balance" ledger-display-balance-at-point ledger-works] + ["Reconcile Account" ledger-reconcile ledger-works] + "---" + ["Toggle Current Transaction" ledger-toggle-current-transaction] + ["Toggle Current Posting" ledger-toggle-current] + ["Copy Trans at Point" ledger-copy-transaction-at-point] + "---" + ["Clean-up Buffer" ledger-mode-clean-buffer] + ["Align Region" ledger-post-align-postings mark-active] + ["Align Xact" ledger-post-align-xact] + ["Sort Region" ledger-sort-region mark-active] + ["Sort Buffer" ledger-sort-buffer] + ["Mark Sort Beginning" ledger-sort-insert-start-mark] + ["Mark Sort End" ledger-sort-insert-end-mark] + ["Set effective date" ledger-insert-effective-date] + "---" + ["Customize Ledger Mode" (lambda () (interactive) (customize-group 'ledger))] + ["Set Year" ledger-set-year ledger-works] + ["Set Month" ledger-set-month ledger-works] + "---" + ["Run Report" ledger-report ledger-works] + ["Goto Report" ledger-report-goto ledger-works] + ["Re-run Report" ledger-report-redo ledger-works] + ["Save Report" ledger-report-save ledger-works] + ["Edit Report" ledger-report-edit ledger-works] + ["Kill Report" ledger-report-kill ledger-works])) ;;;###autoload (define-derived-mode ledger-mode text-mode "Ledger" - "A mode for editing ledger data files." - (ledger-check-version) - (ledger-post-setup) - - (set (make-local-variable 'comment-start) "; ") - (set (make-local-variable 'comment-end) "") - (set (make-local-variable 'indent-tabs-mode) nil) - - (if (boundp 'font-lock-defaults) - (set (make-local-variable 'font-lock-defaults) - '(ledger-font-lock-keywords nil t))) - (setq font-lock-extend-region-functions - (list #'font-lock-extend-region-wholelines)) - (setq font-lock-multiline nil) - - (set (make-local-variable 'pcomplete-parse-arguments-function) - 'ledger-parse-arguments) - (set (make-local-variable 'pcomplete-command-completion-function) - 'ledger-complete-at-point) - (set (make-local-variable 'pcomplete-termination-string) "") - - (add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t) - (add-hook 'before-revert-hook 'ledger-occur-remove-all-overlays nil t) - (make-variable-buffer-local 'highlight-overlay) - - (ledger-init-load-init-file) - - (set (make-local-variable 'indent-region-function) 'ledger-post-align-postings) - - (let ((map (current-local-map))) - (define-key map [(control ?c) (control ?a)] 'ledger-add-transaction) - (define-key map [(control ?c) (control ?b)] 'ledger-post-edit-amount) - (define-key map [(control ?c) (control ?c)] 'ledger-toggle-current) - (define-key map [(control ?c) (control ?d)] 'ledger-delete-current-transaction) - (define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-transaction) - (define-key map [(control ?c) (control ?f)] 'ledger-occur) - (define-key map [(control ?c) (control ?k)] 'ledger-copy-transaction-at-point) - (define-key map [(control ?c) (control ?m)] 'ledger-set-month) - (define-key map [(control ?c) (control ?r)] 'ledger-reconcile) - (define-key map [(control ?c) (control ?s)] 'ledger-sort-region) - (define-key map [(control ?c) (control ?t)] 'ledger-insert-effective-date) - (define-key map [(control ?c) (control ?u)] 'ledger-schedule-upcoming) - (define-key map [(control ?c) (control ?y)] 'ledger-set-year) - (define-key map [(control ?c) (control ?p)] 'ledger-display-balance-at-point) - (define-key map [(control ?c) (control ?l)] 'ledger-display-ledger-stats) - (define-key map [(control ?c) (control ?q)] 'ledger-post-align-xact) - - (define-key map [tab] 'ledger-magic-tab) - (define-key map [(control tab)] 'ledger-post-align-xact) - (define-key map [(control ?i)] 'ledger-magic-tab) - (define-key map [(control ?c) tab] 'ledger-fully-complete-xact) - (define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-xact) - - (define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo) - (define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit) - (define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto) - (define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill) - (define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report) - (define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save) - - (define-key map [(meta ?p)] 'ledger-post-prev-xact) - (define-key map [(meta ?n)] 'ledger-post-next-xact) - - (define-key map [menu-bar] (make-sparse-keymap "ledger-menu")) - (define-key map [menu-bar ledger-menu] (cons "Ledger" map)) - - (define-key map [report-kill] '(menu-item "Kill Report" ledger-report-kill :enable ledger-works)) - (define-key map [report-edit] '(menu-item "Edit Report" ledger-report-edit :enable ledger-works)) - (define-key map [report-save] '(menu-item "Save Report" ledger-report-save :enable ledger-works)) - (define-key map [report-rrun] '(menu-item "Re-run Report" ledger-report-redo :enable ledger-works)) - (define-key map [report-goto] '(menu-item "Goto Report" ledger-report-goto :enable ledger-works)) - (define-key map [report-run] '(menu-item "Run Report" ledger-report :enable ledger-works)) - (define-key map [sep5] '(menu-item "--")) - (define-key map [set-month] '(menu-item "Set Month" ledger-set-month :enable ledger-works)) - (define-key map [set-year] '(menu-item "Set Year" ledger-set-year :enable ledger-works)) - (define-key map [cust] '(menu-item "Customize Ledger Mode" (lambda () - (interactive) - (customize-group 'ledger)))) - (define-key map [sep1] '("--")) - (define-key map [effective-date] '(menu-item "Set effective date" ledger-insert-effective-date)) - (define-key map [sort-end] '(menu-item "Mark Sort End" ledger-sort-insert-end-mark)) - (define-key map [sort-start] '(menu-item "Mark Sort Beginning" ledger-sort-insert-start-mark)) - (define-key map [sort-buff] '(menu-item "Sort Buffer" ledger-sort-buffer)) - (define-key map [sort-reg] '(menu-item "Sort Region" ledger-sort-region :enable mark-active)) - (define-key map [align-xact] '(menu-item "Align Xact" ledger-post-align-xact)) - (define-key map [align-reg] '(menu-item "Align Region" ledger-post-align-postings :enable mark-active)) - (define-key map [clean-buf] '(menu-item "Clean-up Buffer" ledger-mode-clean-buffer)) - (define-key map [sep2] '(menu-item "--")) - (define-key map [copy-xact] '(menu-item "Copy Trans at Point" ledger-copy-transaction-at-point)) - (define-key map [toggle-post] '(menu-item "Toggle Current Posting" ledger-toggle-current)) - (define-key map [toggle-xact] '(menu-item "Toggle Current Transaction" ledger-toggle-current-transaction)) - (define-key map [sep4] '(menu-item "--")) - (define-key map [recon-account] '(menu-item "Reconcile Account" ledger-reconcile :enable ledger-works)) - (define-key map [check-balance] '(menu-item "Check Balance" ledger-display-balance-at-point :enable ledger-works)) - (define-key map [sep6] '(menu-item "--")) - (define-key map [edit-amount] '(menu-item "Calc on Amount" ledger-post-edit-amount)) - (define-key map [sep] '(menu-item "--")) - (define-key map [delete-xact] '(menu-item "Delete Transaction" ledger-delete-current-transaction)) - (define-key map [cmp-xact] '(menu-item "Complete Transaction" ledger-fully-complete-xact)) - (define-key map [add-xact] '(menu-item "Add Transaction (ledger xact)" ledger-add-transaction :enable ledger-works)) - (define-key map [sep3] '(menu-item "--")) - (define-key map [stats] '(menu-item "Ledger Statistics" ledger-display-ledger-stats :enable ledger-works)) - (define-key map [fold-buffer] '(menu-item "Narrow to REGEX" ledger-occur)))) + "A mode for editing ledger data files." + (ledger-check-version) + (when (boundp 'font-lock-defaults) + (setq font-lock-defaults + '(ledger-font-lock-keywords t t nil nil + (font-lock-fontify-region-function . ledger-fontify-buffer-part)))) + + (set (make-local-variable 'pcomplete-parse-arguments-function) 'ledger-parse-arguments) + (set (make-local-variable 'pcomplete-command-completion-function) 'ledger-complete-at-point) + (add-hook 'completion-at-point-functions 'pcomplete-completions-at-point nil t) + (add-hook 'after-save-hook 'ledger-report-redo) + + (add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t) + + (ledger-init-load-init-file) + (setq comment-start ";") + (set (make-local-variable 'indent-region-function) 'ledger-post-align-postings)) (defun ledger-set-year (newyear) "Set ledger's idea of the current year to the prefix argument NEWYEAR." (interactive "p") - (if (= newyear 1) - (setq ledger-year (read-string "Year: " (ledger-current-year))) - (setq ledger-year (number-to-string newyear)))) + (setq ledger-year + (if (= newyear 1) + (read-string "Year: " (ledger-current-year)) + (number-to-string newyear)))) (defun ledger-set-month (newmonth) "Set ledger's idea of the current month to the prefix argument NEWMONTH." (interactive "p") - (if (= newmonth 1) - (setq ledger-month (read-string "Month: " (ledger-current-month))) - (setq ledger-month (format "%02d" newmonth)))) + (setq ledger-month + (if (= newmonth 1) + (read-string "Month: " (ledger-current-month)) + (format "%02d" newmonth)))) diff --git a/lisp/ledger-navigate.el b/lisp/ledger-navigate.el new file mode 100644 index 00000000..904faf8c --- /dev/null +++ b/lisp/ledger-navigate.el @@ -0,0 +1,168 @@ +;;; ledger-navigate.el --- Provide navigation services through the ledger buffer. + +;; Copyright (C) 2014-2015 Craig Earls (enderw88 AT gmail DOT com) + +;; 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., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. + + +;;; Commentary: +;; + +;;; Code: + +(require 'ledger-regex) +(require 'ledger-context) + +(defun ledger-navigate-next-xact () + "Move point to beginning of next xact." + ;; make sure we actually move to the next xact, even if we are the + ;; beginning of one now. + (if (looking-at ledger-payee-any-status-regex) + (forward-line)) + (if (re-search-forward ledger-payee-any-status-regex nil t) + (goto-char (match-beginning 0)) + (goto-char (point-max)))) + +(defun ledger-navigate-start-xact-or-directive-p () + "Return t if at the beginning of an empty or all-whitespace line." + (not (looking-at "[ \t]\\|\\(^$\\)"))) + +(defun ledger-navigate-next-xact-or-directive () + "Move to the beginning of the next xact or directive." + (interactive) + (beginning-of-line) + (if (ledger-navigate-start-xact-or-directive-p) ; if we are the start of an xact, move forward to the next xact + (progn + (forward-line) + (if (not (ledger-navigate-start-xact-or-directive-p)) ; we have moved forward and are not at another xact, recurse forward + (ledger-navigate-next-xact-or-directive))) + (while (not (or (eobp) ; we didn't start off at the beginning of an xact + (ledger-navigate-start-xact-or-directive-p))) + (forward-line)))) + +(defun ledger-navigate-prev-xact-or-directive () + "Move point to beginning of previous xact." + (interactive) + (let ((context (car (ledger-context-at-point)))) + (when (equal context 'acct-transaction) + (ledger-navigate-beginning-of-xact)) + (beginning-of-line) + (re-search-backward "^[[:graph:]]" nil t))) + +(defun ledger-navigate-beginning-of-xact () + "Move point to the beginning of the current xact." + (interactive) + ;; need to start at the beginning of a line incase we are in the first line of an xact already. + (beginning-of-line) + (let ((sreg (concat "^\\(=\\|~\\|" ledger-iso-date-regexp "\\)"))) + (unless (looking-at sreg) + (re-search-backward sreg nil t) + (beginning-of-line))) + (point)) + +(defun ledger-navigate-end-of-xact () + "Move point to end of xact." + (interactive) + (ledger-navigate-next-xact-or-directive) + (re-search-backward ".$") + (end-of-line) + (point)) + +(defun ledger-navigate-to-line (line-number) + "Rapidly move point to line LINE-NUMBER." + (goto-char (point-min)) + (forward-line (1- line-number))) + +(defun ledger-navigate-find-xact-extents (pos) + "Return list containing point for beginning and end of xact containing POS. +Requires empty line separating xacts." + (interactive "d") + (save-excursion + (goto-char pos) + (list (ledger-navigate-beginning-of-xact) + (ledger-navigate-end-of-xact)))) + +(defun ledger-navigate-find-directive-extents (pos) + "Return the extents of the directive at POS." + (goto-char pos) + (let ((begin (progn (beginning-of-line) + (point))) + (end (progn (end-of-line) + (+ 1 (point))))) + ;; handle block comments here + (beginning-of-line) + (if (looking-at " *;") + (progn + (while (and (looking-at " *;") + (> (point) (point-min))) + (forward-line -1)) + ;; We are either at the beginning of the buffer, or we found + ;; a line outside the comment. If we are not at the + ;; beginning of the buffer then we need to move forward a + ;; line. + (if (> (point) (point-min)) + (progn (forward-line 1) + (beginning-of-line))) + (setq begin (point)) + (goto-char pos) + (beginning-of-line) + (while (and (looking-at " *;") + (< (point) (point-max))) + (forward-line 1)) + (setq end (point)))) + (list begin end))) + +(defun ledger-navigate-block-comment (pos) + "Move past the block comment at POS, and return its extents." + (interactive "d") + (goto-char pos) + (let ((begin (progn (beginning-of-line) + (point))) + (end (progn (end-of-line) + (point)))) + ;; handle block comments here + (beginning-of-line) + (if (looking-at " *;") + (progn + (while (and (looking-at " *;") + (> (point) (point-min))) + (forward-line -1)) + (setq begin (point)) + (goto-char pos) + (beginning-of-line) + (while (and (looking-at " *;") + (< (point) (point-max))) + (forward-line 1)) + (setq end (point)))) + (list begin end))) + + +(defun ledger-navigate-find-element-extents (pos) + "Return list containing beginning and end of the entity surrounding POS." + (interactive "d") + (save-excursion + (goto-char pos) + (beginning-of-line) + (if (looking-at "[ =~0-9]") + (ledger-navigate-find-xact-extents pos) + (ledger-navigate-find-directive-extents pos)))) + + +(provide 'ledger-navigate) + +;;; ledger-navigate.el ends here diff --git a/lisp/ledger-occur.el b/lisp/ledger-occur.el index 33d3a56c..a4fde2e1 100644 --- a/lisp/ledger-occur.el +++ b/lisp/ledger-occur.el @@ -1,6 +1,6 @@ -;;; ledger-mode.el --- Helper code for use with the "ledger" command-line tool +;;; ledger-occur.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: ;; Provide buffer narrowing to ledger mode. Adapted from original loccur @@ -29,6 +29,9 @@ ;;; Code: +(require 'cl) +(require 'ledger-navigate) + (defconst ledger-occur-overlay-property-name 'ledger-occur-custom-buffer-grep) (defcustom ledger-occur-use-face-shown t @@ -38,154 +41,127 @@ (make-variable-buffer-local 'ledger-occur-use-face-shown) -(defvar ledger-occur-mode nil - "name of the minor mode, shown in the mode-line") +(defvar ledger-occur-history nil + "History of previously searched expressions for the prompt.") -(make-variable-buffer-local 'ledger-occur-mode) +(defvar ledger-occur-current-regex nil + "Pattern currently applied to narrow the buffer.") +(make-variable-buffer-local 'ledger-occur-current-regex) -(or (assq 'ledger-occur-mode minor-mode-alist) - (nconc minor-mode-alist - (list '(ledger-occur-mode ledger-occur-mode)))) +(defvar ledger-occur-mode-map (make-sparse-keymap)) -(defvar ledger-occur-history nil - "History of previously searched expressions for the prompt.") +(define-minor-mode ledger-occur-mode + "A minor mode which display only transactions matching `ledger-occur-current-regex'." + nil + (:eval (format " Ledger-Narrow(%s)" ledger-occur-current-regex)) + ledger-occur-mode-map + (if (and ledger-occur-current-regex ledger-occur-mode) + (ledger-occur-refresh) + (ledger-occur-remove-overlays) + (message "Showing all transactions"))) -(defvar ledger-occur-last-match nil - "Last match found.") -(make-variable-buffer-local 'ledger-occur-last-match) +(define-key ledger-occur-mode-map (kbd "C-c C-g") 'ledger-occur-refresh) +(define-key ledger-occur-mode-map (kbd "C-c C-f") 'ledger-occur-mode) -(defun ledger-occur-remove-all-overlays () - "Remove all overlays from the ledger buffer." +(defun ledger-occur-refresh () + "Re-apply the current narrowing expression." (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)) + (let ((matches (ledger-occur-compress-matches + (ledger-occur-find-matches ledger-occur-current-regex)))) + (if matches + (ledger-occur-create-overlays matches) + (message "No matches found for '%s'" ledger-occur-current-regex) + (ledger-occur-mode -1)))) (defun ledger-occur (regex) - "Perform a simple grep in current buffer for the regular expression REGEX. + "Show only transactions in the current buffer which match 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" +This command hides all xact in the current buffer except those +matching REGEX. If REGEX is nil or empty, turn off any narrowing +currently active." (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))) + (list (read-regexp "Regexp" (ledger-occur-prompt) 'ledger-occur-history))) + (if (or (null regex) + (zerop (length regex))) ; empty regex, or already have narrowed, clear narrowing + (ledger-occur-mode -1) + (setq ledger-occur-current-regex regex) + (ledger-occur-mode 1))) (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)) + (if (use-region-p) + (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))) (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))) + (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))) + (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)) + (let* ((beg (caar ovl-bounds)) + (end (cadar ovl-bounds))) + (ledger-occur-remove-overlays) + (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-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)) + (point-max) ledger-occur-overlay-property-name t)) (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))) + (let (endpoint lines bounds) ;; 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))))) + (setq bounds (ledger-navigate-find-element-extents endpoint)) + (push bounds lines) + ;; move to the end of the xact, no need to search inside it more + (goto-char (cadr bounds)))) + (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)))) + "identify sequential xacts to reduce number of overlays required" + (if buffer-matches + (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) diff --git a/lisp/ledger-post.el b/lisp/ledger-post.el index 5d30e954..e0c7aaee 100644 --- a/lisp/ledger-post.el +++ b/lisp/ledger-post.el @@ -1,6 +1,6 @@ ;;; ledger-post.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: @@ -42,25 +42,12 @@ :group 'ledger-post) (defcustom ledger-post-use-completion-engine :built-in - "Which completion engine to use, :iswitchb or :ido chose those engines, + "Which completion engine to use, :iswitchb or :ido chose those engines. :built-in uses built-in Ledger-mode completion" - :type '(radio (const :tag "built in completion" :built-in) - (const :tag "ido completion" :ido) - (const :tag "iswitchb completion" :iswitchb) ) - :group 'ledger-post) - -(defun ledger-post-all-accounts () - "Return a list of all accounts in the buffer." - (let ((origin (point)) - (ledger-post-list nil) - account elements) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward ledger-post-line-regexp nil t) - (unless (and (>= origin (match-beginning 0)) - (< origin (match-end 0))) - (add-to-list 'ledger-post-list (ledger-regex-post-line-account)))) - (nreverse ledger-post-list)))) + :type '(radio (const :tag "built in completion" :built-in) + (const :tag "ido completion" :ido) + (const :tag "iswitchb completion" :iswitchb) ) + :group 'ledger-post) (declare-function iswitchb-read-buffer "iswitchb" (prompt &optional default require-match start matches-set)) @@ -72,47 +59,18 @@ PROMPT is a string to prompt with. CHOICES is a list of strings to choose from." (cond ((eq ledger-post-use-completion-engine :iswitchb) - (let* ((iswitchb-use-virtual-buffers nil) - (iswitchb-make-buflist-hook - (lambda () - (setq iswitchb-temp-buflist choices)))) - (iswitchb-read-buffer prompt))) - ((eq ledger-post-use-completion-engine :ido) - (ido-completing-read prompt choices)) - (t - (completing-read prompt choices)))) - -(defvar ledger-post-current-list nil) - -(defun ledger-post-pick-account () - "Insert an account entered by the user." - (interactive) - (let* ((account - (ledger-post-completing-read - "Account: " (or ledger-post-current-list - (setq ledger-post-current-list - (ledger-post-all-accounts))))) - (account-len (length account)) - (pos (point))) - (goto-char (line-beginning-position)) - (when (re-search-forward ledger-post-line-regexp (line-end-position) t) - (let ((existing-len (length (ledger-regex-post-line-account)))) - (goto-char (match-beginning ledger-regex-post-line-group-account)) - (delete-region (match-beginning ledger-regex-post-line-group-account) - (match-end ledger-regex-post-line-group-account)) - (insert account) - (cond - ((> existing-len account-len) - (insert (make-string (- existing-len account-len) ? ))) - ((< existing-len account-len) - (dotimes (n (- account-len existing-len)) - (if (looking-at "[ \t]\\( [ \t]\\|\t\\)") - (delete-char 1))))))) - (goto-char pos))) - - - -(defsubst ledger-next-amount (&optional end) + (let* ((iswitchb-use-virtual-buffers nil) + (iswitchb-make-buflist-hook + (lambda () + (setq iswitchb-temp-buflist choices)))) + (iswitchb-read-buffer prompt))) + ((eq ledger-post-use-completion-engine :ido) + (ido-completing-read prompt choices)) + (t + (completing-read prompt choices)))) + + +(defun ledger-next-amount (&optional end) "Move point to the next amount, as long as it is not past END. Return the width of the amount field as an integer and leave point at beginning of the commodity." @@ -124,82 +82,78 @@ point at beginning of the commodity." (- (or (match-end 4) (match-end 3)) (point))))) - (defun ledger-next-account (&optional end) - "Move point to the beginning of the next account, or status marker (!*), as long as it is not past END. + "Move to the beginning of the posting, or status marker, limit to END. Return the column of the beginning of the account and leave point at beginning of account" - (if (> end (point)) - (when (re-search-forward ledger-account-any-status-regex (1+ end) t) - ;; the 1+ is to make sure we can catch the newline - (if (match-beginning 1) - (goto-char (match-beginning 1)) - (goto-char (match-beginning 2))) - (current-column)))) + (if (> end (point)) + (when (re-search-forward ledger-account-any-status-regex (1+ end) t) + ;; the 1+ is to make sure we can catch the newline + (if (match-beginning 1) + (goto-char (match-beginning 1)) + (goto-char (match-beginning 2))) + (current-column)))) (defun ledger-post-align-xact (pos) + "Align all the posting in the xact at POS." (interactive "d") - (let ((bounds (ledger-find-xact-extents pos))) - (ledger-post-align-postings (car bounds) (cadr bounds)))) + (let ((bounds (ledger-navigate-find-xact-extents pos))) + (ledger-post-align-postings (car bounds) (cadr bounds)))) (defun ledger-post-align-postings (&optional beg end) - "Align all accounts and amounts within region, if there is no -region align the posting on the current line." + "Align all accounts and amounts between BEG and END, or the current line." (interactive) - (assert (eq major-mode 'ledger-mode)) (save-excursion (if (or (not (mark)) - (not (use-region-p))) - (set-mark (point))) - - (let* ((inhibit-modification-hooks t) - (mark-first (< (mark) (point))) - (begin-region (if beg - beg - (if mark-first (mark) (point)))) - (end-region (if end - end - (if mark-first (point) (mark)))) - acct-start-column acct-end-column acct-adjust amt-width - (lines-left 1)) - ;; Condition point and mark to the beginning and end of lines - (goto-char end-region) - (setq end-region (line-end-position)) - (goto-char begin-region) - (goto-char - (setq begin-region - (line-beginning-position))) - - ;; This is the guts of the alignment loop - (while (and (or (setq acct-start-column (ledger-next-account (line-end-position))) - lines-left) - (< (point) end-region)) - (when acct-start-column - (setq acct-end-column (save-excursion - (goto-char (match-end 2)) - (current-column))) - (when (/= (setq acct-adjust (- ledger-post-account-alignment-column acct-start-column)) 0) - (setq acct-end-column (+ acct-end-column acct-adjust)) ;;adjust the account ending column - (if (> acct-adjust 0) - (insert (make-string acct-adjust ? )) - (delete-char acct-adjust))) - (when (setq amt-width (ledger-next-amount (line-end-position))) - (if (/= 0 (setq amt-adjust (- (if (> (- ledger-post-amount-alignment-column amt-width) - (+ 2 acct-end-column)) - ledger-post-amount-alignment-column ;;we have room - (+ acct-end-column 2 amt-width)) - amt-width - (current-column)))) - (if (> amt-adjust 0) - (insert (make-string amt-adjust ? )) - (delete-char amt-adjust))))) - (forward-line) - (setq lines-left (not (eobp)))) + (not (use-region-p))) + (set-mark (point))) + + (let ((inhibit-modification-hooks t) + (mark-first (< (mark) (point))) + acct-start-column acct-end-column acct-adjust amt-width amt-adjust + (lines-left 1)) + + (unless beg (setq beg (if mark-first (mark) (point)))) + (unless end (setq end (if mark-first (mark) (point)))) + + ;; Extend region to whole lines + (let ((start-marker (set-marker (make-marker) (save-excursion + (goto-char beg) + (line-beginning-position)))) + (end-marker (set-marker (make-marker) (save-excursion + (goto-char end) + (line-end-position))))) + (untabify start-marker end-marker) + (goto-char start-marker) + + ;; This is the guts of the alignment loop + (while (and (or (setq acct-start-column (ledger-next-account (line-end-position))) + lines-left) + (< (point) end-marker)) + (when acct-start-column + (setq acct-end-column (save-excursion + (goto-char (match-end 2)) + (current-column))) + (when (/= (setq acct-adjust (- ledger-post-account-alignment-column acct-start-column)) 0) + (setq acct-end-column (+ acct-end-column acct-adjust)) ;;adjust the account ending column + (if (> acct-adjust 0) + (insert (make-string acct-adjust ? )) + (delete-char acct-adjust))) + (when (setq amt-width (ledger-next-amount (line-end-position))) + (if (/= 0 (setq amt-adjust (- (if (> (- ledger-post-amount-alignment-column amt-width) + (+ 2 acct-end-column)) + ledger-post-amount-alignment-column ;;we have room + (+ acct-end-column 2 amt-width)) + amt-width + (current-column)))) + (if (> amt-adjust 0) + (insert (make-string amt-adjust ? )) + (delete-char amt-adjust))))) + (forward-line) + (setq lines-left (not (eobp))))) (setq inhibit-modification-hooks nil)))) - - (defun ledger-post-edit-amount () "Call 'calc-mode' and push the amount in the posting to the top of stack." (interactive) @@ -209,39 +163,16 @@ region align the posting on the current line." (let ((end-of-amount (re-search-forward "[-.,0-9]+" (line-end-position) t))) ;; determine if there is an amount to edit (if end-of-amount - (let ((val (ledger-string-to-number (match-string 0)))) - (goto-char (match-beginning 0)) - (delete-region (match-beginning 0) (match-end 0)) - (calc) - (calc-eval val 'push)) ;; edit the amount - (progn ;;make sure there are two spaces after the account name and go to calc - (if (search-backward " " (- (point) 3) t) - (goto-char (line-end-position)) - (insert " ")) - (calc)))))) - -(defun ledger-post-prev-xact () - "Move point to the previous transaction." - (interactive) - (backward-paragraph) - (when (re-search-backward ledger-xact-line-regexp nil t) - (goto-char (match-beginning 0)) - (re-search-forward ledger-post-line-regexp) - (goto-char (match-end ledger-regex-post-line-group-account)))) - -(defun ledger-post-next-xact () - "Move point to the next transaction." - (interactive) - (when (re-search-forward ledger-xact-line-regexp nil t) - (goto-char (match-beginning 0)) - (re-search-forward ledger-post-line-regexp) - (goto-char (match-end ledger-regex-post-line-group-account)))) - -(defun ledger-post-setup () - "Configure `ledger-mode' to auto-align postings." - (add-hook 'after-save-hook #'(lambda () (setq ledger-post-current-list nil)) t t)) - - + (let ((val-string (match-string 0))) + (goto-char (match-beginning 0)) + (delete-region (match-beginning 0) (match-end 0)) + (calc) + (calc-eval val-string 'push)) ;; edit the amount + (progn ;;make sure there are two spaces after the account name and go to calc + (if (search-backward " " (- (point) 3) t) + (goto-char (line-end-position)) + (insert " ")) + (calc)))))) (provide 'ledger-post) diff --git a/lisp/ledger-reconcile.el b/lisp/ledger-reconcile.el index 8ca78dbc..80e27ae3 100644 --- a/lisp/ledger-reconcile.el +++ b/lisp/ledger-reconcile.el @@ -1,6 +1,6 @@ ;;; ledger-reconcile.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;; Reconcile mode @@ -27,13 +27,16 @@ ;;; Code: +(require 'easymenu) +(require 'ledger-init) + (defvar ledger-buf nil) (defvar ledger-bufs nil) (defvar ledger-acct nil) (defvar ledger-target nil) (defgroup ledger-reconcile nil - "Options for Ledger-mode reconciliation" + "Options for Ledger-mode reconciliation" :group 'ledger) (defcustom ledger-recon-buffer-name "*Reconcile*" @@ -59,26 +62,51 @@ Then that transaction will be shown in its source buffer." (defcustom ledger-reconcile-toggle-to-pending t "If true then toggle between uncleared and pending. reconcile-finish will mark all pending posting cleared." - :type 'boolean - :group 'ledger-reconcile) + :type 'boolean + :group 'ledger-reconcile) -(defcustom ledger-reconcile-default-date-format "%Y/%m/%d" - "Default date format for the reconcile buffer" +(defcustom ledger-reconcile-default-date-format ledger-default-date-format + "Default date format for the reconcile buffer." :type 'string :group 'ledger-reconcile) (defcustom ledger-reconcile-target-prompt-string "Target amount for reconciliation " - "Default prompt for recon target prompt" + "Default prompt for recon target prompt." :type 'string :group 'ledger-reconcile) -(defcustom ledger-reconcile-sort-key "(date)" - "Default key for sorting reconcile buffer. For no sorting by default, use '(0)'." +(defcustom ledger-reconcile-buffer-header "Reconciling account %s\n\n" + "Default header string for the reconcile buffer. + +If non-nil, the name of the account being reconciled will be substituted + into the '%s'. If nil, no header willbe displayed." + :type 'string + :group 'ledger-reconcile) + +(defcustom ledger-reconcile-buffer-line-format "%(date)s %-4(code)s %-50(payee)s %-30(account)s %15(amount)s\n" + "Format string for the ledger reconcile posting format. +Available fields are date, status, code, payee, account, +amount. The format for each field is %WIDTH(FIELD), WIDTH can be +preced by a minus sign which mean to left justify and pad the +field." :type 'string :group 'ledger-reconcile) +(defcustom ledger-reconcile-sort-key "(0)" + "Default key for sorting reconcile buffer. + +Possible values are '(date)', '(amount)', '(payee)'. For no sorting, i.e. using +ledger file order, use '(0)'." + :type 'string + :group 'ledger-reconcile) + +(defcustom ledger-reconcile-insert-effective-date nil + "If t, prompt for effective date when clearing transactions during reconciliation." + :type 'boolean + :group 'ledger-reconcile) + (defun ledger-reconcile-get-cleared-or-pending-balance (buffer account) - "Calculate the cleared or pending balance of the account." + "Use BUFFER to Calculate the cleared or pending balance of the ACCOUNT." ;; these vars are buffer local, need to hold them for use in the ;; temp buffer below @@ -89,10 +117,10 @@ reconcile-finish will mark all pending posting cleared." ;; split arguments like the shell does, so you need to ;; specify the individual fields in the command line. (if (ledger-exec-ledger buffer (current-buffer) - "balance" "--limit" "cleared or pending" "--empty" "--collapse" - "--format" "%(display_total)" account) - (ledger-split-commodity-string - (buffer-substring-no-properties (point-min) (point-max)))))) + "balance" "--limit" "cleared or pending" "--empty" "--collapse" + "--format" "%(scrub(display_total))" account) + (ledger-split-commodity-string + (buffer-substring-no-properties (point-min) (point-max)))))) (defun ledger-display-balance () "Display the cleared-or-pending balance. @@ -100,14 +128,14 @@ And calculate the target-delta of the account being reconciled." (interactive) (let* ((pending (ledger-reconcile-get-cleared-or-pending-balance ledger-buf ledger-acct))) (when pending - (if ledger-target - (message "Pending balance: %s, Difference from target: %s" - (ledger-commodity-to-string pending) - (ledger-commodity-to-string (-commodity ledger-target pending))) - (message "Pending balance: %s" - (ledger-commodity-to-string pending)))))) - -(defun is-stdin (file) + (if ledger-target + (message "Cleared and Pending balance: %s, Difference from target: %s" + (ledger-commodity-to-string pending) + (ledger-commodity-to-string (-commodity ledger-target pending))) + (message "Pending balance: %s" + (ledger-commodity-to-string pending)))))) + +(defun ledger-is-stdin (file) "True if ledger FILE is standard input." (or (equal file "") @@ -118,7 +146,7 @@ And calculate the target-delta of the account being reconciled." "Return a buffer from WHERE the transaction is." (if (bufferp (car where)) (car where) - (error "Function ledger-reconcile-get-buffer: Buffer not set"))) + (error "Function ledger-reconcile-get-buffer: Buffer not set"))) (defun ledger-reconcile-toggle () "Toggle the current transaction, and mark the recon window." @@ -129,27 +157,30 @@ And calculate the target-delta of the account being reconciled." status) (when (ledger-reconcile-get-buffer where) (with-current-buffer (ledger-reconcile-get-buffer where) - (ledger-goto-line (cdr where)) - (forward-char) - (setq status (ledger-toggle-current (if ledger-reconcile-toggle-to-pending - 'pending - 'cleared)))) - ;; remove the existing face and add the new face + (ledger-navigate-to-line (cdr where)) + (forward-char) + (setq status (ledger-toggle-current (if ledger-reconcile-toggle-to-pending + 'pending + 'cleared))) + (when ledger-reconcile-insert-effective-date + ;; Ask for effective date & insert it + (ledger-insert-effective-date))) + ;; 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)) (cond ((eq status 'pending) - (add-text-properties (line-beginning-position) - (line-end-position) - (list 'face 'ledger-font-reconciler-pending-face ))) - ((eq status 'cleared) - (add-text-properties (line-beginning-position) - (line-end-position) - (list 'face 'ledger-font-reconciler-cleared-face ))) - (t - (add-text-properties (line-beginning-position) - (line-end-position) - (list 'face 'ledger-font-reconciler-uncleared-face ))))) + (add-text-properties (line-beginning-position) + (line-end-position) + (list 'face 'ledger-font-reconciler-pending-face ))) + ((eq status 'cleared) + (add-text-properties (line-beginning-position) + (line-end-position) + (list 'face 'ledger-font-reconciler-cleared-face ))) + (t + (add-text-properties (line-beginning-position) + (line-end-position) + (list 'face 'ledger-font-reconciler-uncleared-face ))))) (forward-line) (beginning-of-line) (ledger-display-balance))) @@ -161,20 +192,21 @@ Return the number of uncleared xacts found." (let ((inhibit-read-only t)) (erase-buffer) (prog1 - (ledger-do-reconcile ledger-reconcile-sort-key) + (ledger-do-reconcile ledger-reconcile-sort-key) (set-buffer-modified-p t)))) (defun ledger-reconcile-refresh-after-save () "Refresh the recon-window after the ledger buffer is saved." - (let ((curbuf (current-buffer)) - (curpoint (point)) - (recon-buf (get-buffer ledger-recon-buffer-name))) + (let ((curbufwin (get-buffer-window (current-buffer))) + (curpoint (point)) + (recon-buf (get-buffer ledger-recon-buffer-name))) (when (buffer-live-p recon-buf) (with-current-buffer recon-buf - (ledger-reconcile-refresh) - (set-buffer-modified-p nil)) - (select-window (get-buffer-window curbuf)) - (goto-char curpoint)))) + (ledger-reconcile-refresh) + (set-buffer-modified-p nil)) + (when curbufwin + (select-window curbufwin) + (goto-char curpoint))))) (defun ledger-reconcile-add () "Use ledger xact to add a new transaction." @@ -189,45 +221,46 @@ Return the number of uncleared xacts found." (let ((where (get-text-property (point) 'where))) (when (ledger-reconcile-get-buffer where) (with-current-buffer (ledger-reconcile-get-buffer where) - (ledger-goto-line (cdr where)) - (ledger-delete-current-transaction)) + (ledger-navigate-to-line (cdr where)) + (ledger-delete-current-transaction (point))) (let ((inhibit-read-only t)) (goto-char (line-beginning-position)) (delete-region (point) (1+ (line-end-position))) - (set-buffer-modified-p t))))) + (set-buffer-modified-p t)) + (ledger-reconcile-refresh)))) (defun ledger-reconcile-visit (&optional come-back) "Recenter ledger buffer on transaction and COME-BACK if non-nil." (interactive) - (progn - (beginning-of-line) - (let* ((where (get-text-property (1+ (point)) 'where)) - (target-buffer (if where - (ledger-reconcile-get-buffer where) - nil)) - (cur-win (get-buffer-window (get-buffer ledger-recon-buffer-name)))) - (when target-buffer - (switch-to-buffer-other-window target-buffer) - (ledger-goto-line (cdr where)) - (forward-char) - (recenter) - (ledger-highlight-xact-under-point) - (forward-char -1) - (if (and come-back cur-win) - (select-window cur-win)))))) + (beginning-of-line) + (let* ((where (get-text-property (1+ (point)) 'where)) + (target-buffer (if where + (ledger-reconcile-get-buffer where) + nil)) + (cur-win (get-buffer-window (get-buffer ledger-recon-buffer-name)))) + (when target-buffer + (switch-to-buffer-other-window target-buffer) + (ledger-navigate-to-line (cdr where)) + (forward-char) + (recenter) + (ledger-highlight-xact-under-point) + (forward-char -1) + (when (and come-back cur-win) + (select-window cur-win) + (get-buffer ledger-recon-buffer-name))))) + (defun ledger-reconcile-save () "Save the ledger buffer." (interactive) - (let ((curpoint (point))) - (dolist (buf (cons ledger-buf ledger-bufs)) - (with-current-buffer buf - (save-buffer))) - (with-current-buffer (get-buffer ledger-recon-buffer-name) - (set-buffer-modified-p nil) - (ledger-display-balance) - (goto-char curpoint) - (ledger-reconcile-visit t)))) + (let ((cur-buf (current-buffer)) + (cur-point (point))) + (dolist (buf (cons ledger-buf ledger-bufs)) + (with-current-buffer buf + (basic-save-buffer))) + (switch-to-buffer-other-window cur-buf) + (goto-char cur-point))) + (defun ledger-reconcile-finish () "Mark all pending posting or transactions as cleared. @@ -241,162 +274,198 @@ and exit reconcile mode" (face (get-text-property (point) 'face))) (if (eq face 'ledger-font-reconciler-pending-face) (with-current-buffer (ledger-reconcile-get-buffer where) - (ledger-goto-line (cdr where)) + (ledger-navigate-to-line (cdr where)) (ledger-toggle-current 'cleared)))) (forward-line 1))) (ledger-reconcile-save) - (ledger-reconcile-quit)) + (ledger-reconcile-quit)) (defun ledger-reconcile-quit () "Quit the reconcile window without saving ledger buffer." (interactive) (let ((recon-buf (get-buffer ledger-recon-buffer-name)) - buf) + buf) (if recon-buf - (with-current-buffer recon-buf - (ledger-reconcile-quit-cleanup) - (setq buf ledger-buf) - ;; Make sure you delete the window before you delete the buffer, - ;; otherwise, madness ensues - (delete-window (get-buffer-window recon-buf)) - (kill-buffer recon-buf) - (set-window-buffer (selected-window) buf))))) + (with-current-buffer recon-buf + (ledger-reconcile-quit-cleanup) + (setq buf ledger-buf) + ;; Make sure you delete the window before you delete the buffer, + ;; otherwise, madness ensues + (delete-window (get-buffer-window recon-buf)) + (kill-buffer recon-buf) + (set-window-buffer (selected-window) buf))))) (defun ledger-reconcile-quit-cleanup () "Cleanup all hooks established by reconcile mode." (interactive) (let ((buf ledger-buf)) (if (buffer-live-p buf) - (with-current-buffer buf - (remove-hook 'after-save-hook 'ledger-reconcile-refresh-after-save t) - (when ledger-narrow-on-reconcile - (ledger-occur-quit-buffer buf) - (ledger-highlight-xact-under-point)))))) + (with-current-buffer buf + (remove-hook 'after-save-hook 'ledger-reconcile-refresh-after-save t) + (when ledger-narrow-on-reconcile + (ledger-occur-mode -1) + (ledger-highlight-xact-under-point)))))) (defun ledger-marker-where-xact-is (emacs-xact posting) "Find the position of the EMACS-XACT in the `ledger-buf'. POSTING is used in `ledger-clear-whole-transactions' is nil." - (let ((buf (if (is-stdin (nth 0 emacs-xact)) - ledger-buf - (find-file-noselect (nth 0 emacs-xact))))) + (let ((buf (if (ledger-is-stdin (nth 0 emacs-xact)) + ledger-buf + (find-file-noselect (nth 0 emacs-xact))))) (cons buf (if ledger-clear-whole-transactions - (nth 1 emacs-xact) ;; return line-no of xact - (nth 0 posting))))) ;; return line-no of posting + (nth 1 emacs-xact) ;; return line-no of xact + (nth 0 posting))))) ;; return line-no of posting + +(defun ledger-reconcile-compile-format-string (fstr) + "Return a function that implements the format string in FSTR." + (let (fields + (start 0)) + (while (string-match "(\\(.*?\\))" fstr start) + (setq fields (cons (intern (match-string 1 fstr)) fields)) + (setq start (match-end 0))) + (setq fields (list* 'format (replace-regexp-in-string "(.*?)" "" fstr) (nreverse fields))) + `(lambda (date code status payee account amount) + ,fields))) + + + +(defun ledger-reconcile-format-posting (beg where fmt date code status payee account amount) + "Format posting for the reconcile buffer." + (insert (funcall fmt date code status payee account amount)) + + ; Set face depending on cleared status + (if status + (if (eq status 'pending) + (set-text-properties beg (1- (point)) + (list 'face 'ledger-font-reconciler-pending-face + 'where where)) + (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)))) + +(defun ledger-reconcile-format-xact (xact fmt) + "Format XACT using FMT." + (let ((date-format (or (cdr (assoc "date-format" ledger-environment-alist)) + ledger-default-date-format))) + (dolist (posting (nthcdr 5 xact)) + (let ((beg (point)) + (where (ledger-marker-where-xact-is xact posting))) + (ledger-reconcile-format-posting beg + where + fmt + (format-time-string date-format (nth 2 xact)) ; date + (if (nth 3 xact) (nth 3 xact) "") ; code + (nth 3 posting) ; status + (nth 4 xact) ; payee + (nth 1 posting) ; account + (nth 2 posting)))))) ; amount (defun ledger-do-reconcile (&optional sort) - "Return the number of uncleared transactions in the account and display them in the *Reconcile* buffer." + "SORT the uncleared transactions in the account and display them in the *Reconcile* buffer. +Return a count of the uncleared transactions." (let* ((buf ledger-buf) (account ledger-acct) - (ledger-success nil) - (sort-by (if sort - sort - "(date)")) + (ledger-success nil) + (sort-by (if sort + sort + "(date)")) (xacts (with-temp-buffer - (when (ledger-exec-ledger buf (current-buffer) - "--uncleared" "--real" "emacs" "--sort" sort-by account) - (setq ledger-success t) - (goto-char (point-min)) - (unless (eobp) - (if (looking-at "(") - (read (current-buffer)))))))) ;current-buffer is the *temp* created above + (when (ledger-exec-ledger buf (current-buffer) + "--uncleared" "--real" "emacs" "--sort" sort-by account) + (setq ledger-success t) + (goto-char (point-min)) + (unless (eobp) + (if (looking-at "(") + (read (current-buffer))))))) ;current-buffer is the *temp* created above + (fmt (ledger-reconcile-compile-format-string ledger-reconcile-buffer-line-format))) (if (and ledger-success (> (length xacts) 0)) - (let ((date-format (cdr (assoc "date-format" ledger-environment-alist)))) - (dolist (xact xacts) - (dolist (posting (nthcdr 5 xact)) - (let ((beg (point)) - (where (ledger-marker-where-xact-is xact posting))) - (insert (format "%s %-4s %-30s %-30s %15s\n" - (format-time-string (if date-format - date-format - ledger-reconcile-default-date-format) (nth 2 xact)) - (if (nth 3 xact) - (nth 3 xact) - "") - (nth 4 xact) (nth 1 posting) (nth 2 posting))) - (if (nth 3 posting) - (if (eq (nth 3 posting) 'pending) - (set-text-properties beg (1- (point)) - (list 'face 'ledger-font-reconciler-pending-face - 'where where)) - (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)))) )) - (goto-char (point-max)) - (delete-char -1)) ;gets rid of the extra line feed at the bottom of the list - (if ledger-success - (insert (concat "There are no uncleared entries for " account)) - (insert "Ledger has reported a problem. Check *Ledger Error* buffer."))) + (progn + (insert (format ledger-reconcile-buffer-header account)) + (dolist (xact xacts) + (ledger-reconcile-format-xact xact fmt)) + (goto-char (point-max)) + (delete-char -1)) ;gets rid of the extra line feed at the bottom of the list + (if ledger-success + (insert (concat "There are no uncleared entries for " account)) + (insert "Ledger has reported a problem. Check *Ledger Error* buffer."))) (goto-char (point-min)) (set-buffer-modified-p nil) - (toggle-read-only t) + (setq buffer-read-only t) (ledger-reconcile-ensure-xacts-visible) (length xacts))) (defun ledger-reconcile-ensure-xacts-visible () - "Ensures that the last of the visible transactions in the -ledger buffer is at the bottom of the main window. The key to -this is to ensure the window is selected when the buffer point is + "Ensure the last of the visible transactions in the ledger buffer is at the bottom of the main window. +The key to this is to ensure the window is selected when the buffer point is moved and recentered. If they aren't strange things happen." - (let ((recon-window (get-buffer-window (get-buffer ledger-recon-buffer-name)))) - (when recon-window - (fit-window-to-buffer recon-window) - (with-current-buffer buf - (add-hook 'kill-buffer-hook 'ledger-reconcile-quit nil t) - (if (get-buffer-window buf) - (select-window (get-buffer-window buf))) - (goto-char (point-max)) - (recenter -1)) - (select-window recon-window) - (ledger-reconcile-visit t)) - (add-hook 'post-command-hook 'ledger-reconcile-track-xact nil t))) + (let ((recon-window (get-buffer-window (get-buffer ledger-recon-buffer-name)))) + (when recon-window + (fit-window-to-buffer recon-window) + (with-current-buffer ledger-buf + (add-hook 'kill-buffer-hook 'ledger-reconcile-quit nil t) + (if (get-buffer-window ledger-buf) + (select-window (get-buffer-window ledger-buf))) + (goto-char (point-max)) + (recenter -1)) + (select-window recon-window) + (ledger-reconcile-visit t)) + (add-hook 'post-command-hook 'ledger-reconcile-track-xact nil t))) (defun ledger-reconcile-track-xact () "Force the ledger buffer to recenter on the transaction at point in the reconcile buffer." (if (and ledger-buffer-tracks-reconcile-buffer - (member this-command (list 'next-line - 'previous-line - 'mouse-set-point - 'ledger-reconcile-toggle - 'end-of-buffer - 'beginning-of-buffer))) + (member this-command (list 'next-line + 'previous-line + 'mouse-set-point + 'ledger-reconcile-toggle + 'end-of-buffer + 'beginning-of-buffer))) (save-excursion - (ledger-reconcile-visit t)))) + (ledger-reconcile-visit t)))) (defun ledger-reconcile-open-windows (buf rbuf) "Ensure that the ledger buffer BUF is split by RBUF." (if ledger-reconcile-force-window-bottom ;;create the *Reconcile* window directly below the ledger buffer. (set-window-buffer (split-window (get-buffer-window buf) nil nil) rbuf) - (pop-to-buffer rbuf))) + (pop-to-buffer rbuf))) + +(defun ledger-reconcile-check-valid-account (account) + "Check to see if ACCOUNT exists in the ledger file" + (if (> (length account) 0) + (save-excursion + (goto-char (point-min)) + (search-forward account nil t)))) (defun ledger-reconcile () "Start reconciling, prompt for account." (interactive) (let ((account (ledger-read-account-with-prompt "Account to reconcile")) - (buf (current-buffer)) + (buf (current-buffer)) (rbuf (get-buffer ledger-recon-buffer-name))) - (add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save nil t) + (when (ledger-reconcile-check-valid-account account) + (add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save nil t) - (if rbuf ;; *Reconcile* already exists - (with-current-buffer rbuf - (set 'ledger-acct account) ;; already buffer local - (when (not (eq buf rbuf)) - ;; called from some other ledger-mode buffer - (ledger-reconcile-quit-cleanup) - (set 'ledger-buf buf)) ;; should already be buffer-local + (if rbuf ;; *Reconcile* already exists + (with-current-buffer rbuf + (set 'ledger-acct account) ;; already buffer local + (when (not (eq buf rbuf)) + ;; called from some other ledger-mode buffer + (ledger-reconcile-quit-cleanup) + (setq ledger-buf buf)) ;; should already be buffer-local - (unless (get-buffer-window rbuf) - (ledger-reconcile-open-windows buf rbuf))) + (unless (get-buffer-window rbuf) + (ledger-reconcile-open-windows buf rbuf))) ;; no recon-buffer, starting from scratch. @@ -408,14 +477,14 @@ moved and recentered. If they aren't strange things happen." (set (make-local-variable 'ledger-buf) buf) (set (make-local-variable 'ledger-acct) account))) - ;; Narrow the ledger buffer - (with-current-buffer rbuf - (save-excursion - (if ledger-narrow-on-reconcile - (ledger-occur-mode account ledger-buf))) - (if (> (ledger-reconcile-refresh) 0) - (ledger-reconcile-change-target)) - (ledger-display-balance)))) + ;; Narrow the ledger buffer + (with-current-buffer rbuf + (save-excursion + (if ledger-narrow-on-reconcile + (ledger-occur account))) + (if (> (ledger-reconcile-refresh) 0) + (ledger-reconcile-change-target)) + (ledger-display-balance))))) (defvar ledger-reconcile-mode-abbrev-table) @@ -425,65 +494,71 @@ moved and recentered. If they aren't strange things happen." (setq ledger-target (ledger-read-commodity-string ledger-reconcile-target-prompt-string))) (defmacro ledger-reconcile-change-sort-key-and-refresh (sort-by) + "Set the sort-key to SORT-BY." `(lambda () - (interactive) - - (setq ledger-reconcile-sort-key ,sort-by) - (ledger-reconcile-refresh))) + (interactive) + + (setq ledger-reconcile-sort-key ,sort-by) + (ledger-reconcile-refresh))) + +(defvar ledger-reconcile-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?m)] 'ledger-reconcile-visit) + (define-key map [return] 'ledger-reconcile-visit) + (define-key map [(control ?x) (control ?s)] 'ledger-reconcile-save) + (define-key map [(control ?l)] 'ledger-reconcile-refresh) + (define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish) + (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); + (define-key map [?n] 'next-line) + (define-key map [?p] 'previous-line) + (define-key map [?t] 'ledger-reconcile-change-target) + (define-key map [?s] 'ledger-reconcile-save) + (define-key map [?q] 'ledger-reconcile-quit) + (define-key map [?b] 'ledger-display-balance) + + (define-key map [(control ?c) (control ?o)] (ledger-reconcile-change-sort-key-and-refresh "(0)")) + + (define-key map [(control ?c) (control ?a)] (ledger-reconcile-change-sort-key-and-refresh "(amount)")) + + (define-key map [(control ?c) (control ?d)] (ledger-reconcile-change-sort-key-and-refresh "(date)")) + + (define-key map [(control ?c) (control ?p)] (ledger-reconcile-change-sort-key-and-refresh "(payee)")) + map) + "Keymap for `ledger-reconcile-mode'.") + +(easy-menu-define ledger-reconcile-mode-menu ledger-reconcile-mode-map + "Ledger reconcile menu" + `("Reconcile" + ["Save" ledger-reconcile-save] + ["Refresh" ledger-reconcile-refresh] + ["Finish" ledger-reconcile-finish] + "---" + ["Reconcile New Account" ledger-reconcile] + "---" + ["Change Target Balance" ledger-reconcile-change-target] + ["Show Cleared Balance" ledger-display-balance] + "---" + ["Sort by payee" ,(ledger-reconcile-change-sort-key-and-refresh "(payee)")] + ["Sort by date" ,(ledger-reconcile-change-sort-key-and-refresh "(date)")] + ["Sort by amount" ,(ledger-reconcile-change-sort-key-and-refresh "(amount)")] + ["Sort by file order" ,(ledger-reconcile-change-sort-key-and-refresh "(0)")] + "---" + ["Toggle Entry" ledger-reconcile-toggle] + ["Add Entry" ledger-reconcile-add] + ["Delete Entry" ledger-reconcile-delete] + "---" + ["Next Entry" next-line] + ["Visit Source" ledger-reconcile-visit] + ["Previous Entry" previous-line] + "---" + ["Quit" ledger-reconcile-quit] + )) (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 ?l)] 'ledger-reconcile-refresh) - (define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish) - (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); - (define-key map [?n] 'next-line) - (define-key map [?p] 'previous-line) - (define-key map [?t] 'ledger-reconcile-change-target) - (define-key map [?s] 'ledger-reconcile-save) - (define-key map [?q] 'ledger-reconcile-quit) - (define-key map [?b] 'ledger-display-balance) - - (define-key map [(control ?c) (control ?o)] (ledger-reconcile-change-sort-key-and-refresh "(0)")) - - (define-key map [(control ?c) (control ?a)] (ledger-reconcile-change-sort-key-and-refresh "(amount)")) - - (define-key map [(control ?c) (control ?d)] (ledger-reconcile-change-sort-key-and-refresh "(date)")) - - (define-key map [(control ?c) (control ?p)] (ledger-reconcile-change-sort-key-and-refresh "(payee)")) - - (define-key map [menu-bar] (make-sparse-keymap "ledger-recon-menu")) - (define-key map [menu-bar ledger-recon-menu] (cons "Reconcile" map)) - (define-key map [menu-bar ledger-recon-menu qui] '("Quit" . ledger-reconcile-quit)) - (define-key map [menu-bar ledger-recon-menu sep1] '("--")) - (define-key map [menu-bar ledger-recon-menu pre] '("Previous Entry" . previous-line)) - (define-key map [menu-bar ledger-recon-menu vis] '("Visit Source" . ledger-reconcile-visit)) - (define-key map [menu-bar ledger-recon-menu nex] '("Next Entry" . next-line)) - (define-key map [menu-bar ledger-recon-menu sep2] '("--")) - (define-key map [menu-bar ledger-recon-menu del] '("Delete Entry" . ledger-reconcile-delete)) - (define-key map [menu-bar ledger-recon-menu add] '("Add Entry" . ledger-reconcile-add)) - (define-key map [menu-bar ledger-recon-menu tog] '("Toggle Entry" . ledger-reconcile-toggle)) - (define-key map [menu-bar ledger-recon-menu sep3] '("--")) - (define-key map [menu-bar ledger-recon-menu sort-orig] `("Sort by file order" . ,(ledger-reconcile-change-sort-key-and-refresh "(0)"))) - (define-key map [menu-bar ledger-recon-menu sort-amt] `("Sort by amount" . ,(ledger-reconcile-change-sort-key-and-refresh "(amount)"))) - (define-key map [menu-bar ledger-recon-menu sort-pay] `("Sort by date" . ,(ledger-reconcile-change-sort-key-and-refresh "(date)"))) - (define-key map [menu-bar ledger-recon-menu sort-dat] `("Sort by payee" . ,(ledger-reconcile-change-sort-key-and-refresh "(payee)"))) - (define-key map [menu-bar ledger-recon-menu sep4] '("--")) - (define-key map [menu-bar ledger-recon-menu bal] '("Show Cleared Balance" . ledger-display-balance)) - (define-key map [menu-bar ledger-recon-menu tgt] '("Change Target Balance" . ledger-reconcile-change-target)) - (define-key map [menu-bar ledger-recon-menu sep5] '("--")) - (define-key map [menu-bar ledger-recon-menu rna] '("Reconcile New Account" . ledger-reconcile)) - (define-key map [menu-bar ledger-recon-menu sep6] '("--")) - (define-key map [menu-bar ledger-recon-menu fin] '("Finish" . ledger-reconcile-finish)) - (define-key map [menu-bar ledger-recon-menu ref] '("Refresh" . ledger-reconcile-refresh)) - (define-key map [menu-bar ledger-recon-menu sav] '("Save" . ledger-reconcile-save)) - - (use-local-map map))) + "A mode for reconciling ledger entries.") (provide 'ledger-reconcile) diff --git a/lisp/ledger-regex.el b/lisp/ledger-regex.el index 77ce38c6..41231845 100644 --- a/lisp/ledger-regex.el +++ b/lisp/ledger-regex.el @@ -1,6 +1,6 @@ ;;; ledger-regex.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. (require 'rx) @@ -26,12 +26,12 @@ (defconst ledger-amount-regex (concat "\\( \\|\t\\| \t\\)[ \t]*-?" - "\\([A-Z$€£_]+ *\\)?" - "\\(-?[0-9,]+?\\)" - "\\(.[0-9]+\\)?" - "\\( *[[:word:]€£_\"]+\\)?" - "\\([ \t]*[@={]@?[^\n;]+?\\)?" - "\\([ \t]+;.+?\\|[ \t]*\\)?$")) + "\\([A-Z$€£₹_(]+ *\\)?" + "\\(-?[0-9,\\.]+?\\)" + "\\(.[0-9)]+\\)?" + "\\( *[[:word:]€£₹_\"]+\\)?" + "\\([ \t]*[@={]@?[^\n;]+?\\)?" + "\\([ \t]+;.+?\\|[ \t]*\\)?$")) (defconst ledger-amount-decimal-comma-regex "-?[1-9][0-9.]*[,]?[0-9]*") @@ -68,10 +68,10 @@ "^--.+?\\($\\|[ ]\\)") (defconst ledger-account-any-status-regex - "^[ \t]+\\([*!]\\s-+\\)?\\([[(]?.+?\\)\\(\t\\|\n\\| [ \t]\\)") + "^[ \t]+\\([*!]\\s-+\\)?\\([[(]?.+?\\)\\(\t\\|\n\\| [ \t]\\)") (defun ledger-account-any-status-with-seed-regex (seed) - (concat "^[ \t]+\\([*!]\\s-+\\)?\\([[(]?" seed ".+?\\)\\(\t\\|\n\\| [ \t]\\)")) + (concat "^[ \t]+\\([*!]\\s-+\\)?\\([[(]?" seed ".+?\\)\\(\t\\|\n\\| [ \t]\\)")) (defconst ledger-account-pending-regex "\\(^[ \t]+\\)\\(!\\s-*.*?\\)\\( \\|\t\\|$\\)") @@ -83,10 +83,10 @@ (defmacro ledger-define-regexp (name regex docs &rest args) "Simplify the creation of a Ledger regex and helper functions." (let ((defs - (list - `(defconst - ,(intern (concat "ledger-" (symbol-name name) "-regexp")) - ,(eval regex)))) + (list + `(defconst + ,(intern (concat "ledger-" (symbol-name name) "-regexp")) + ,(eval regex)))) (addend 0) last-group) (if (null args) (progn @@ -94,242 +94,268 @@ defs (list `(defconst - ,(intern - (concat "ledger-regex-" (symbol-name name) "-group")) + ,(intern + (concat "ledger-regex-" (symbol-name name) "-group")) 1))) (nconc defs (list `(defconst - ,(intern (concat "ledger-regex-" (symbol-name name) - "-group--count")) + ,(intern (concat "ledger-regex-" (symbol-name name) + "-group--count")) 1))) (nconc defs (list `(defmacro - ,(intern (concat "ledger-regex-" (symbol-name name))) - (&optional string) + ,(intern (concat "ledger-regex-" (symbol-name name))) + (&optional string) ,(format "Return the match string for the %s" name) (match-string ,(intern (concat "ledger-regex-" (symbol-name name) "-group")) string))))) - (dolist (arg args) - (let (var grouping target) - (if (symbolp arg) - (setq var arg target arg) - (assert (listp arg)) - (if (= 2 (length arg)) - (setq var (car arg) - target (cadr arg)) - (setq var (car arg) - grouping (cadr arg) - target (caddr arg)))) - - (if (and last-group - (not (eq last-group (or grouping target)))) - (incf addend - (symbol-value - (intern-soft (concat "ledger-regex-" - (symbol-name last-group) - "-group--count"))))) - (nconc - defs - (list - `(defconst - ,(intern (concat "ledger-regex-" (symbol-name name) - "-group-" (symbol-name var))) - ,(+ addend - (symbol-value - (intern-soft - (if grouping - (concat "ledger-regex-" (symbol-name grouping) - "-group-" (symbol-name target)) - (concat "ledger-regex-" (symbol-name target) - "-group")))))))) - (nconc - defs - (list - `(defmacro - ,(intern (concat "ledger-regex-" (symbol-name name) - "-" (symbol-name var))) - (&optional string) - ,(format "Return the sub-group match for the %s %s." - name var) - (match-string - ,(intern (concat "ledger-regex-" (symbol-name name) - "-group-" (symbol-name var))) - string)))) - - (setq last-group (or grouping target)))) - - (nconc defs - (list - `(defconst ,(intern (concat "ledger-regex-" (symbol-name name) - "-group--count")) - ,(length args))))) + (dolist (arg args) + (let (var grouping target) + (if (symbolp arg) + (setq var arg target arg) + (assert (listp arg)) + (if (= 2 (length arg)) + (setq var (car arg) + target (cadr arg)) + (setq var (car arg) + grouping (cadr arg) + target (caddr arg)))) + + (if (and last-group + (not (eq last-group (or grouping target)))) + (incf addend + (symbol-value + (intern-soft (concat "ledger-regex-" + (symbol-name last-group) + "-group--count"))))) + (nconc + defs + (list + `(defconst + ,(intern (concat "ledger-regex-" (symbol-name name) + "-group-" (symbol-name var))) + ,(+ addend + (symbol-value + (intern-soft + (if grouping + (concat "ledger-regex-" (symbol-name grouping) + "-group-" (symbol-name target)) + (concat "ledger-regex-" (symbol-name target) + "-group")))))))) + (nconc + defs + (list + `(defmacro + ,(intern (concat "ledger-regex-" (symbol-name name) + "-" (symbol-name var))) + (&optional string) + ,(format "Return the sub-group match for the %s %s." + name var) + (match-string + ,(intern (concat "ledger-regex-" (symbol-name name) + "-group-" (symbol-name var))) + string)))) + + (setq last-group (or grouping target)))) + + (nconc defs + (list + `(defconst ,(intern (concat "ledger-regex-" (symbol-name name) + "-group--count")) + ,(length args))))) (cons 'progn defs))) (put 'ledger-define-regexp 'lisp-indent-function 1) (ledger-define-regexp iso-date - ( let ((sep '(or ?- ?/))) - (rx (group - (and (group (? (= 4 num))) - (eval sep) - (group (and num (? num))) - (eval sep) - (group (and num (? num))))))) - "Match a single date, in its 'written' form.") + ( let ((sep '(or ?- ?/))) + (rx (group + (and (? (and (group (= 4 num))) + (eval sep)) + (group (and num (? num))) + (eval sep) + (group (and num (? num))))))) + "Match a single date, in its 'written' form.") (ledger-define-regexp full-date - (macroexpand - `(rx (and (regexp ,ledger-iso-date-regexp) - (? (and ?= (regexp ,ledger-iso-date-regexp)))))) - "Match a compound date, of the form ACTUAL=EFFECTIVE" - (actual iso-date) - (effective iso-date)) + (macroexpand + `(rx (and (regexp ,ledger-iso-date-regexp) + (? (and ?= (regexp ,ledger-iso-date-regexp)))))) + "Match a compound date, of the form ACTUAL=EFFECTIVE" + (actual iso-date) + (effective iso-date)) (ledger-define-regexp state - (rx (group (any ?! ?*))) - "Match a transaction or posting's \"state\" character.") + (rx (group (any ?! ?*))) + "Match a transaction or posting's \"state\" character.") (ledger-define-regexp code - (rx (and ?\( (group (+? (not (any ?\))))) ?\))) - "Match the transaction code.") + (rx (and ?\( (group (+? (not (any ?\))))) ?\))) + "Match the transaction code.") (ledger-define-regexp long-space - (rx (and (*? blank) - (or (and ? (or ? ?\t)) ?\t))) - "Match a \"long space\".") + (rx (and (*? blank) + (or (and ? (or ? ?\t)) ?\t))) + "Match a \"long space\".") (ledger-define-regexp note - (rx (group (+ nonl))) - "") + (rx (group (+ nonl))) + "") (ledger-define-regexp end-note - (macroexpand - `(rx (and (regexp ,ledger-long-space-regexp) ?\; - (regexp ,ledger-note-regexp)))) - "") + (macroexpand + `(rx (and (regexp ,ledger-long-space-regexp) ?\; + (regexp ,ledger-note-regexp)))) + "") (ledger-define-regexp full-note - (macroexpand - `(rx (and line-start (+ blank) - ?\; (regexp ,ledger-note-regexp)))) - "") + (macroexpand + `(rx (and line-start (+ blank) + ?\; (regexp ,ledger-note-regexp)))) + "") (ledger-define-regexp xact-line - (macroexpand - `(rx (and line-start - (regexp ,ledger-full-date-regexp) - (? (and (+ blank) (regexp ,ledger-state-regexp))) - (? (and (+ blank) (regexp ,ledger-code-regexp))) - (+ blank) (+? nonl) - (? (regexp ,ledger-end-note-regexp)) - line-end))) - "Match a transaction's first line (and optional notes)." - (actual-date full-date actual) - (effective-date full-date effective) - state - code - (note end-note)) + (macroexpand + `(rx (and line-start + (regexp ,ledger-full-date-regexp) + (? (and (+ blank) (regexp ,ledger-state-regexp))) + (? (and (+ blank) (regexp ,ledger-code-regexp))) + (+ blank) (+? nonl) + (? (regexp ,ledger-end-note-regexp)) + line-end))) + "Match a transaction's first line (and optional notes)." + (actual-date full-date actual) + (effective-date full-date effective) + state + code + (note end-note)) (ledger-define-regexp account - (rx (group (and (not (any blank ?\[ ?\( ?: ?\;)) (*? nonl)))) - "") + (rx (group (and (not (any blank ?\[ ?\( ?: ?\;)) (*? nonl)))) + "") (ledger-define-regexp account-kind - (rx (group (? (any ?\[ ?\()))) - "") + (rx (group (? (any ?\[ ?\()))) + "") (ledger-define-regexp full-account - (macroexpand - `(rx (and (regexp ,ledger-account-kind-regexp) - (regexp ,ledger-account-regexp) - (? (any ?\] ?\)))))) - "" - (kind account-kind) - (name account)) + (macroexpand + `(rx (and (regexp ,ledger-account-kind-regexp) + (regexp ,ledger-account-regexp) + (? (any ?\] ?\)))))) + "" + (kind account-kind) + (name account)) (ledger-define-regexp commodity - (rx (group - (or (and ?\" (+ (not (any ?\"))) ?\") - (not (any blank ?\n - digit - ?- ?\[ ?\] - ?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?= - ?\< ?\> ?\{ ?\} ?\( ?\) ?@))))) - "") + (rx (group + (or (and ?\" (+ (not (any ?\"))) ?\") + (not (any blank ?\n + digit + ?- ?\[ ?\] + ?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?= + ?\< ?\> ?\{ ?\} ?\( ?\) ?@))))) + "") (ledger-define-regexp amount - (rx (group - (and (? ?-) - (and (+ digit) - (*? (and (any ?. ?,) (+ digit)))) - (? (and (any ?. ?,) (+ digit)))))) - "") + (rx (group + (and (? ?-) + (and (+ digit) + (*? (and (any ?. ?,) (+ digit)))) + (? (and (any ?. ?,) (+ digit)))))) + "") (ledger-define-regexp commoditized-amount - (macroexpand - `(rx (group - (or (and (regexp ,ledger-commodity-regexp) - (*? blank) - (regexp ,ledger-amount-regexp)) - (and (regexp ,ledger-amount-regexp) - (*? blank) - (regexp ,ledger-commodity-regexp)))))) - "") + (macroexpand + `(rx (group + (or (and (regexp ,ledger-commodity-regexp) + (*? blank) + (regexp ,ledger-amount-regexp)) + (and (regexp ,ledger-amount-regexp) + (*? blank) + (regexp ,ledger-commodity-regexp)))))) + "") (ledger-define-regexp commodity-annotations - (macroexpand - `(rx (* (+ blank) - (or (and ?\{ (regexp ,ledger-commoditized-amount-regexp) ?\}) - (and ?\[ (regexp ,ledger-iso-date-regexp) ?\]) - (and ?\( (not (any ?\))) ?\)))))) - "") + (macroexpand + `(rx (* (+ blank) + (or (and ?\{ (regexp ,ledger-commoditized-amount-regexp) ?\}) + (and ?\[ (regexp ,ledger-iso-date-regexp) ?\]) + (and ?\( (not (any ?\))) ?\)))))) + "") (ledger-define-regexp cost - (macroexpand - `(rx (and (or "@" "@@") (+ blank) - (regexp ,ledger-commoditized-amount-regexp)))) - "") + (macroexpand + `(rx (and (or "@" "@@") (+ blank) + (regexp ,ledger-commoditized-amount-regexp)))) + "") (ledger-define-regexp balance-assertion - (macroexpand - `(rx (and ?= (+ blank) - (regexp ,ledger-commoditized-amount-regexp)))) - "") + (macroexpand + `(rx (and ?= (+ blank) + (regexp ,ledger-commoditized-amount-regexp)))) + "") (ledger-define-regexp full-amount - (macroexpand `(rx (group (+? (not (any ?\;)))))) - "") + (macroexpand `(rx (group (+? (not (any ?\;)))))) + "") (ledger-define-regexp post-line - (macroexpand - `(rx (and line-start (+ blank) - (? (and (regexp ,ledger-state-regexp) (* blank))) - (regexp ,ledger-full-account-regexp) - (? (and (regexp ,ledger-long-space-regexp) - (regexp ,ledger-full-amount-regexp))) - (? (regexp ,ledger-end-note-regexp)) - line-end))) - "" - state - (account-kind full-account kind) - (account full-account name) - (amount full-amount) - (note end-note)) + (macroexpand + `(rx (and line-start (+ blank) + (? (and (regexp ,ledger-state-regexp) (* blank))) + (regexp ,ledger-full-account-regexp) + (? (and (regexp ,ledger-long-space-regexp) + (regexp ,ledger-full-amount-regexp))) + (? (regexp ,ledger-end-note-regexp)) + line-end))) + "" + state + (account-kind full-account kind) + (account full-account name) + (amount full-amount) + (note end-note)) (defconst ledger-iterate-regex - (concat "\\(Y\\s-+\\([0-9]+\\)\\|" ;; Catches a Y directive - ledger-iso-date-regexp - "\\([ *!]+\\)" ;; mark - "\\((.*)\\)?" ;; code - "\\(.*\\)" ;; desc - "\\)")) + (concat "\\(\\(?:Y\\|year\\)\\s-+\\([0-9]+\\)\\|" ;; Catches a Y/year directive + ledger-iso-date-regexp + "\\([ *!]+\\)" ;; mark + "\\((.*)\\)?" ;; code + "\\([[:word:] ]+\\)" ;; desc + "\\)")) + +(defconst ledger-xact-start-regex + (concat "^" ledger-iso-date-regexp ;; subexp 1 + "\\(=" ledger-iso-date-regexp "\\)?" + )) + +(defconst ledger-xact-after-date-regex + (concat "\\([ \t]+[*!]\\)?" ;; mark, subexp 1 + "\\([ \t]+(.*?)\\)?" ;; code, subexp 2 + "\\([ \t]+[^;\n]+\\)" ;; desc, subexp 3 + "\\(;[^\n]*\\)?" ;; comment, subexp 4 + )) + +(defconst ledger-posting-regex + (concat "^[ \t]+ ?" ;; initial white space + "\\([*!]\\)? ?" ;; state, subexpr 1 + "\\([[:print:]]+\\([ \t][ \t]\\)\\)" ;; account, subexpr 2 + "\\([^;\n]*\\)" ;; amount, subexpr 4 + "\\(.*\\)" ;; comment, subexpr 5 + )) + + + +(defconst ledger-directive-start-regex + "[=~;#%|\\*[A-Za-z]") + (provide 'ledger-regex) diff --git a/lisp/ledger-report.el b/lisp/ledger-report.el index e785bc1b..c477707f 100644 --- a/lisp/ledger-report.el +++ b/lisp/ledger-report.el @@ -1,6 +1,6 @@ ;;; ledger-report.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: @@ -25,6 +25,7 @@ ;;; Code: +(require 'easymenu) (eval-when-compile (require 'cl)) @@ -49,14 +50,15 @@ the substitution. See the documentation of the individual functions in that variable for more information on the behavior of each specifier." :type '(repeat (list (string :tag "Report Name") - (string :tag "Command Line"))) + (string :tag "Command Line"))) :group 'ledger-report) (defcustom ledger-report-format-specifiers '(("ledger-file" . ledger-report-ledger-file-format-specifier) ("payee" . ledger-report-payee-format-specifier) ("account" . ledger-report-account-format-specifier) - ("value" . ledger-report-value-format-specifier)) + ("tagname" . ledger-report-tagname-format-specifier) + ("tagvalue" . ledger-report-tagvalue-format-specifier)) "An alist mapping ledger report format specifiers to implementing functions. The function is called with no parameters and expected to return the @@ -64,6 +66,16 @@ text that should replace the format specifier." :type 'alist :group 'ledger-report) +(defcustom ledger-report-auto-refresh t + "If t then automatically rerun the report when the ledger buffer is saved." + :type 'boolean + :group 'ledger-report) + +(defcustom ledger-report-auto-refresh-sticky-cursor nil + "If t then try to place cursor at same relative position as it was before auto-refresh." + :type 'boolean + :group 'ledger-report) + (defvar ledger-report-buffer-name "*Ledger Report*") (defvar ledger-report-name nil) @@ -75,8 +87,16 @@ text that should replace the format specifier." (defvar ledger-minibuffer-history nil) (defvar ledger-report-mode-abbrev-table) +(defvar ledger-report-is-reversed nil) +(defvar ledger-report-cursor-line-number nil) + +(defun ledger-report-reverse-report () + "Reverse the order of the report." + (interactive) + (ledger-report-reverse-lines) + (setq ledger-report-is-reversed (not ledger-report-is-reversed))) + (defun ledger-report-reverse-lines () - (interactive) (goto-char (point-min)) (forward-paragraph) (forward-line) @@ -84,51 +104,61 @@ text that should replace the format specifier." (setq inhibit-read-only t) (reverse-region (point) (point-max)))) +(defvar ledger-report-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [? ] 'scroll-up) + (define-key map [backspace] 'scroll-down) + (define-key map [?r] 'ledger-report-redo) + (define-key map [(shift ?r)] 'ledger-report-reverse-report) + (define-key map [?s] 'ledger-report-save) + (define-key map [?k] 'ledger-report-kill) + (define-key map [?e] 'ledger-report-edit-report) + (define-key map [( shift ?e)] 'ledger-report-edit-reports) + (define-key map [?q] 'ledger-report-quit) + (define-key map [?g] 'ledger-report-redo) + (define-key map [(control ?c) (control ?l) (control ?r)] + 'ledger-report-redo) + (define-key map [(control ?c) (control ?l) (control ?S)] + 'ledger-report-save) + (define-key map [(control ?c) (control ?l) (control ?k)] + 'ledger-report-kill) + (define-key map [(control ?c) (control ?l) (control ?e)] + 'ledger-report-edit) + (define-key map [return] 'ledger-report-visit-source) + map) + "Keymap for `ledger-report-mode'.") + +(easy-menu-define ledger-report-mode-menu ledger-report-mode-map + "Ledger report menu" + '("Reports" + ["Save Report" ledger-report-save] + ["Edit Current Report" ledger-report-edit-report] + ["Edit All Reports" ledger-report-edit-reports] + ["Re-run Report" ledger-report-redo] + "---" + ["Reverse report order" ledger-report-reverse-report] + "---" + ["Scroll Up" scroll-up] + ["Visit Source" ledger-report-visit-source] + ["Scroll Down" scroll-down] + "---" + ["Quit" ledger-report-quit] + )) + (define-derived-mode ledger-report-mode text-mode "Ledger-Report" - "A mode for viewing ledger reports." - (let ((map (make-sparse-keymap))) - (define-key map [? ] 'scroll-up) - (define-key map [backspace] 'scroll-down) - (define-key map [?r] 'ledger-report-redo) - (define-key map [(shift ?r)] 'ledger-report-reverse-lines) - (define-key map [?s] 'ledger-report-save) - (define-key map [?k] 'ledger-report-kill) - (define-key map [?e] 'ledger-report-edit) - (define-key map [?q] 'ledger-report-quit) - (define-key map [(control ?c) (control ?l) (control ?r)] - 'ledger-report-redo) - (define-key map [(control ?c) (control ?l) (control ?S)] - 'ledger-report-save) - (define-key map [(control ?c) (control ?l) (control ?k)] - 'ledger-report-kill) - (define-key map [(control ?c) (control ?l) (control ?e)] - 'ledger-report-edit) - (define-key map [return] 'ledger-report-visit-source) - - - (define-key map [menu-bar] (make-sparse-keymap "ledger-rep")) - (define-key map [menu-bar ledger-rep] (cons "Reports" map)) - - (define-key map [menu-bar ledger-rep lrq] '("Quit" . ledger-report-quit)) - (define-key map [menu-bar ledger-rep s2] '("--")) - (define-key map [menu-bar ledger-rep lrd] '("Scroll Down" . scroll-down)) - (define-key map [menu-bar ledger-rep vis] '("Visit Source" . ledger-report-visit-source)) - (define-key map [menu-bar ledger-rep lru] '("Scroll Up" . scroll-up)) - (define-key map [menu-bar ledger-rep s1] '("--")) - (define-key map [menu-bar ledger-rep rev] '("Reverse report order" . ledger-report-reverse-lines)) - (define-key map [menu-bar ledger-rep s0] '("--")) - (define-key map [menu-bar ledger-rep lrk] '("Kill Report" . ledger-report-kill)) - (define-key map [menu-bar ledger-rep lrr] '("Re-run Report" . ledger-report-redo)) - (define-key map [menu-bar ledger-rep lre] '("Edit Report" . ledger-report-edit)) - (define-key map [menu-bar ledger-rep lrs] '("Save Report" . ledger-report-save)) - - (use-local-map map))) - -(defun ledger-report-value-format-specifier () + "A mode for viewing ledger reports.") + +(defun ledger-report-tagname-format-specifier () "Return a valid meta-data tag name" ;; It is intended completion should be available on existing account ;; names, but it remains to be implemented. - (ledger-read-string-with-default "Value: " nil)) + (ledger-read-string-with-default "Tag Name: " nil)) + +(defun ledger-report-tagvalue-format-specifier () + "Return a valid meta-data tag name" + ;; It is intended completion should be available on existing account + ;; names, but it remains to be implemented. + (ledger-read-string-with-default "Tag Value: " nil)) (defun ledger-report-read-name () "Read the name of a ledger report to use, with completion. @@ -173,13 +203,14 @@ used to generate the buffer, navigating the buffer, etc." (set (make-local-variable 'ledger-buf) buf) (set (make-local-variable 'ledger-report-name) report-name) (set (make-local-variable 'ledger-original-window-cfg) wcfg) + (set (make-local-variable 'ledger-report-is-reversed) nil) (ledger-do-report (ledger-report-cmd report-name edit)) (shrink-window-if-larger-than-buffer) (set-buffer-modified-p nil) (setq buffer-read-only t) (message "q to quit; r to redo; e to edit; k to kill; s to save; SPC and DEL to scroll")))) -(defun string-empty-p (s) +(defun ledger-report-string-empty-p (s) "Check S for the empty string." (string-equal "" s)) @@ -188,7 +219,7 @@ used to generate the buffer, navigating the buffer, etc." If name exists, returns the object naming the report, otherwise returns nil." - (unless (string-empty-p name) + (unless (ledger-report-string-empty-p name) (car (assoc name ledger-reports)))) (defun ledger-reports-add (name cmd) @@ -227,7 +258,7 @@ used to generate the buffer, navigating the buffer, etc." end of a ledger file which is included in some other file." (if ledger-master-file (expand-file-name ledger-master-file) - (buffer-file-name))) + (buffer-file-name))) (defun ledger-report-payee-format-specifier () "Substitute a payee name. @@ -257,16 +288,16 @@ used to generate the buffer, navigating the buffer, etc." (let ((expanded-cmd report-cmd)) (set-match-data (list 0 0)) (while (string-match "%(\\([^)]*\\))" expanded-cmd (if (> (length expanded-cmd) (match-end 0)) - (match-end 0) - (1- (length expanded-cmd)))) - (let* ((specifier (match-string 1 expanded-cmd)) - (f (cdr (assoc specifier ledger-report-format-specifiers)))) - (if f - (setq expanded-cmd (replace-match - (save-match-data - (with-current-buffer ledger-buf - (shell-quote-argument (funcall f)))) - t t expanded-cmd))))) + (match-end 0) + (1- (length expanded-cmd)))) + (let* ((specifier (match-string 1 expanded-cmd)) + (f (cdr (assoc specifier ledger-report-format-specifiers)))) + (if f + (setq expanded-cmd (replace-match + (save-match-data + (with-current-buffer ledger-buf + (shell-quote-argument (funcall f)))) + t t expanded-cmd))))) expanded-cmd))) (defun ledger-report-cmd (report-name edit) @@ -279,11 +310,11 @@ Optional EDIT the command." (setq ledger-report-saved nil)) ;; this is a new report, or edited report (setq report-cmd (ledger-report-expand-format-specifiers report-cmd)) (set (make-local-variable 'ledger-report-cmd) report-cmd) - (or (string-empty-p report-name) + (or (ledger-report-string-empty-p report-name) (ledger-report-name-exists report-name) (progn - (ledger-reports-add report-name report-cmd) - (ledger-reports-custom-save))) + (ledger-reports-add report-name report-cmd) + (ledger-reports-custom-save))) report-cmd)) (defun ledger-do-report (cmd) @@ -295,32 +326,32 @@ Optional EDIT the command." "\n\n") (let ((data-pos (point)) (register-report (string-match " reg\\(ister\\)? " cmd)) - files-in-report) + files-in-report) (shell-command ;; --subtotal does not produce identifiable transactions, so don't ;; prepend location information for them (if (and register-report - (not (string-match "--subtotal" cmd))) - (concat cmd " --prepend-format='%(filename):%(beg_line):'") - cmd) + (not (string-match "--subtotal" cmd))) + (concat cmd " --prepend-format='%(filename):%(beg_line):'") + cmd) t nil) (when register-report (goto-char data-pos) (while (re-search-forward "^\\(/[^:]+\\)?:\\([0-9]+\\)?:" nil t) - (let ((file (match-string 1)) - (line (string-to-number (match-string 2)))) - (delete-region (match-beginning 0) (match-end 0)) - (when file - (set-text-properties (line-beginning-position) (line-end-position) - (list 'ledger-source (cons file (save-window-excursion - (save-excursion - (find-file file) - (widen) - (ledger-goto-line line) - (point-marker)))))) - (add-text-properties (line-beginning-position) (line-end-position) - (list 'face 'ledger-font-report-clickable-face)) - (end-of-line))))) + (let ((file (match-string 1)) + (line (string-to-number (match-string 2)))) + (delete-region (match-beginning 0) (match-end 0)) + (when file + (set-text-properties (line-beginning-position) (line-end-position) + (list 'ledger-source (cons file (save-window-excursion + (save-excursion + (find-file file) + (widen) + (ledger-navigate-to-line line) + (point-marker)))))) + (add-text-properties (line-beginning-position) (line-end-position) + (list 'face 'ledger-font-report-clickable-face)) + (end-of-line))))) (goto-char data-pos))) @@ -328,21 +359,21 @@ Optional EDIT the command." "Visit the transaction under point in the report window." (interactive) (let* ((prop (get-text-property (point) 'ledger-source)) - (file (if prop (car prop))) - (line-or-marker (if prop (cdr prop)))) + (file (if prop (car prop))) + (line-or-marker (if prop (cdr prop)))) (when (and file line-or-marker) (find-file-other-window file) (widen) (if (markerp line-or-marker) - (goto-char line-or-marker) - (goto-char (point-min)) - (forward-line (1- line-or-marker)) - (re-search-backward "^[0-9]+") - (beginning-of-line) - (let ((start-of-txn (point))) - (forward-paragraph) - (narrow-to-region start-of-txn (point)) - (backward-paragraph)))))) + (goto-char line-or-marker) + (goto-char (point-min)) + (forward-line (1- line-or-marker)) + (re-search-backward "^[0-9]+") + (beginning-of-line) + (let ((start-of-txn (point))) + (forward-paragraph) + (narrow-to-region start-of-txn (point)) + (backward-paragraph)))))) (defun ledger-report-goto () "Goto the ledger report buffer." @@ -356,34 +387,46 @@ Optional EDIT the command." (defun ledger-report-redo () "Redo the report in the current ledger report buffer." (interactive) - (ledger-report-goto) - (setq buffer-read-only nil) - (erase-buffer) - (ledger-do-report ledger-report-cmd) - (setq buffer-read-only nil)) + (let ((cur-buf (current-buffer))) + (if (and ledger-report-auto-refresh + (or (string= (format-mode-line 'mode-name) "Ledger") + (string= (format-mode-line 'mode-name) "Ledger-Report")) + (get-buffer ledger-report-buffer-name)) + (progn + + (pop-to-buffer (get-buffer ledger-report-buffer-name)) + (shrink-window-if-larger-than-buffer) + (setq buffer-read-only nil) + (setq ledger-report-cursor-line-number (line-number-at-pos)) + (erase-buffer) + (ledger-do-report ledger-report-cmd) + (setq buffer-read-only nil) + (if ledger-report-is-reversed (ledger-report-reverse-lines)) + (if ledger-report-auto-refresh-sticky-cursor (forward-line (- ledger-report-cursor-line-number 5))) + (pop-to-buffer cur-buf))))) (defun ledger-report-quit () - "Quit the ledger report buffer by burying it." - (interactive) - (ledger-report-goto) - (set-window-configuration ledger-original-window-cfg) - (bury-buffer (get-buffer ledger-report-buffer-name))) - -(defun ledger-report-kill () - "Kill the ledger report buffer." - (interactive) - (ledger-report-quit) - (kill-buffer (get-buffer ledger-report-buffer-name))) + "Quit the ledger report buffer." + (interactive) + (ledger-report-goto) + (set-window-configuration ledger-original-window-cfg) + (kill-buffer (get-buffer ledger-report-buffer-name))) -(defun ledger-report-edit () +(defun ledger-report-edit-reports () "Edit the defined ledger reports." (interactive) (customize-variable 'ledger-reports)) +(defun ledger-report-edit-report () + (interactive) + "Edit the current report command in the mini buffer and re-run the report" + (setq ledger-report-cmd (ledger-report-read-command ledger-report-cmd)) + (ledger-report-redo)) + (defun ledger-report-read-new-name () "Read the name for a new report from the minibuffer." (let ((name "")) - (while (string-empty-p name) + (while (ledger-report-string-empty-p name) (setq name (read-from-minibuffer "Report name: " nil nil nil 'ledger-report-name-prompt-history))) name)) @@ -393,26 +436,26 @@ Optional EDIT the command." (interactive) (ledger-report-goto) (let (existing-name) - (when (string-empty-p ledger-report-name) + (when (ledger-report-string-empty-p ledger-report-name) (setq ledger-report-name (ledger-report-read-new-name))) (if (setq existing-name (ledger-report-name-exists ledger-report-name)) - (cond ((y-or-n-p (format "Overwrite existing report named '%s'? " - ledger-report-name)) - (if (string-equal - ledger-report-cmd - (car (cdr (assq existing-name ledger-reports)))) - (message "Nothing to save. Current command is identical to existing saved one") - (progn - (setq ledger-reports - (assq-delete-all existing-name ledger-reports)) - (ledger-reports-add ledger-report-name ledger-report-cmd) - (ledger-reports-custom-save)))) - (t - (progn - (setq ledger-report-name (ledger-report-read-new-name)) - (ledger-reports-add ledger-report-name ledger-report-cmd) - (ledger-reports-custom-save))))))) + (cond ((y-or-n-p (format "Overwrite existing report named '%s'? " + ledger-report-name)) + (if (string-equal + ledger-report-cmd + (car (cdr (assq existing-name ledger-reports)))) + (message "Nothing to save. Current command is identical to existing saved one") + (progn + (setq ledger-reports + (assq-delete-all existing-name ledger-reports)) + (ledger-reports-add ledger-report-name ledger-report-cmd) + (ledger-reports-custom-save)))) + (t + (progn + (setq ledger-report-name (ledger-report-read-new-name)) + (ledger-reports-add ledger-report-name ledger-report-cmd) + (ledger-reports-custom-save))))))) (provide 'ledger-report) diff --git a/lisp/ledger-schedule.el b/lisp/ledger-schedule.el index 7497c7d0..d66fdbab 100644 --- a/lisp/ledger-schedule.el +++ b/lisp/ledger-schedule.el @@ -16,13 +16,13 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: ;; ;; This module provides for automatically adding transactions to a -;; ledger buffer on a periodic basis. Recurrence expressions are +;; ledger buffer on a periodic basis. Recurrence expressions are ;; inspired by Martin Fowler's "Recurring Events for Calendars", ;; martinfowler.com/apsupp/recurring.pdf @@ -30,12 +30,17 @@ ;; function slot of the symbol VARNAME. Then use VARNAME as the ;; function without have to use funcall. +(require 'ledger-init) +(require 'cl) + +;;; Code: + (defgroup ledger-schedule nil "Support for automatically recommendation transactions." :group 'ledger) (defcustom ledger-schedule-buffer-name "*Ledger Schedule*" - "Name for the schedule buffer" + "Name for the schedule buffer." :type 'string :group 'ledger-schedule) @@ -45,284 +50,276 @@ :group 'ledger-schedule) (defcustom ledger-schedule-look-forward 14 - "Number of days auto look forward to recommend transactions" + "Number of days auto look forward to recommend transactions." :type 'integer :group 'ledger-schedule) -(defcustom ledger-schedule-file "~/FinanceData/ledger-schedule.ledger" +(defcustom ledger-schedule-file "~/ledger-schedule.ledger" "File to find scheduled transactions." :type 'file :group 'ledger-schedule) +(defcustom ledger-schedule-week-days '(("Mo" 1) + ("Tu" 2) + ("We" 3) + ("Th" 4) + ("Fr" 5) + ("Sa" 6) + ("Su" 7)) + "List of weekday abbreviations. There must be exactly seven +entries each with a two character abbreviation for a day and the +number of that day in the week. " + :type '(alist :value-type (group integer)) + :group 'ledger-schedule) + (defsubst between (val low high) - (and (>= val low) (<= val high))) + "Return TRUE if VAL > LOW and < HIGH." + (and (>= val low) (<= val high))) (defun ledger-schedule-days-in-month (month year) "Return number of days in the MONTH, MONTH is from 1 to 12. -If year is nil, assume it is not a leap year" +If YEAR is nil, assume it is not a leap year" (if (between month 1 12) (if (and year (date-leap-year-p year) (= 2 month)) - 29 - (nth (1- month) '(31 28 31 30 31 30 31 31 30 31 30 31))) - (error "Month out of range, MONTH=%S" month))) + 29 + (nth (1- month) '(31 28 31 30 31 30 31 31 30 31 30 31))) + (error "Month out of range, MONTH=%S" month))) + +(defun ledger-schedule-encode-day-of-week (day-string) + "Return the numerical day of week corresponding to DAY-STRING." + (cadr (assoc day-string ledger-schedule-week-days))) ;; Macros to handle date expressions (defun ledger-schedule-constrain-day-in-month (count day-of-week) - "Return a form that evaluates DATE that returns true for the COUNT DAY-OF-WEEK. + "Return a form that returns TRUE for the the COUNT DAY-OF-WEEK. For example, return true if date is the 3rd Thursday of the month. Negative COUNT starts from the end of the month. (EQ COUNT 0) means EVERY day-of-week (eg. every Saturday)" (if (and (between count -6 6) (between day-of-week 0 6)) (cond ((zerop count) ;; Return true if day-of-week matches - `(eq (nth 6 (decode-time date)) ,day-of-week)) - ((> count 0) ;; Positive count - (let ((decoded (gensym))) - `(let ((,decoded (decode-time date))) - (and (eq (nth 6 ,decoded) ,day-of-week) - (between (nth 3 ,decoded) - ,(* (1- count) 7) - ,(* count 7)))))) - ((< count 0) - (let ((days-in-month (gensym)) - (decoded (gensym))) - `(let* ((,decoded (decode-time date)) - (,days-in-month (ledger-schedule-days-in-month - (nth 4 ,decoded) - (nth 5 ,decoded)))) - (and (eq (nth 6 ,decoded) ,day-of-week) - (between (nth 3 ,decoded) - (+ ,days-in-month ,(* count 7)) - (+ ,days-in-month ,(* (1+ count) 7))))))) - (t - (error "COUNT out of range, COUNT=%S" count))) - (error "Invalid argument to ledger-schedule-day-in-month-macro %S %S" - count - day-of-week))) + `(eq (nth 6 (decode-time date)) ,day-of-week)) + ((> count 0) ;; Positive count + (let ((decoded (gensym))) + `(let ((,decoded (decode-time date))) + (and (eq (nth 6 ,decoded) ,day-of-week) + (between (nth 3 ,decoded) + ,(* (1- count) 7) + ,(* count 7)))))) + ((< count 0) + (let ((days-in-month (gensym)) + (decoded (gensym))) + `(let* ((,decoded (decode-time date)) + (,days-in-month (ledger-schedule-days-in-month + (nth 4 ,decoded) + (nth 5 ,decoded)))) + (and (eq (nth 6 ,decoded) ,day-of-week) + (between (nth 3 ,decoded) + (+ ,days-in-month ,(* count 7)) + (+ ,days-in-month ,(* (1+ count) 7))))))) + (t + (error "COUNT out of range, COUNT=%S" count))) + (error "Invalid argument to ledger-schedule-day-in-month-macro %S %S" + count + day-of-week))) (defun ledger-schedule-constrain-every-count-day (day-of-week skip start-date) - "Return a form that is true for every DAY skipping SKIP, starting on START. + "Return a form that is true for every DAY-OF-WEEK skipping SKIP, starting on START-DATE. For example every second Friday, regardless of month." - (let ((start-day (nth 6 (decode-time (eval start-date))))) - (if (eq start-day day-of-week) ;; good, can proceed - `(zerop (mod (- (time-to-days date) ,(time-to-days (eval start-date))) ,(* skip 7))) - (error "START-DATE day of week doesn't match DAY-OF-WEEK")))) + (let ((start-day (nth 6 (decode-time start-date)))) + (if (eq start-day day-of-week) ;; good, can proceed + `(zerop (mod (- (time-to-days date) ,(time-to-days start-date)) ,(* skip 7))) + (error "START-DATE day of week doesn't match DAY-OF-WEEK")))) (defun ledger-schedule-constrain-date-range (month1 day1 month2 day2) "Return a form of DATE that is true if DATE falls between MONTH1 DAY1 and MONTH2 DAY2." (let ((decoded (gensym)) - (target-month (gensym)) - (target-day (gensym))) + (target-month (gensym)) + (target-day (gensym))) `(let* ((,decoded (decode-time date)) - (,target-month (nth 4 decoded)) - (,target-day (nth 3 decoded))) + (,target-month (nth 4 decoded)) + (,target-day (nth 3 decoded))) (and (and (> ,target-month ,month1) - (< ,target-month ,month2)) - (and (> ,target-day ,day1) - (< ,target-day ,day2)))))) + (< ,target-month ,month2)) + (and (> ,target-day ,day1) + (< ,target-day ,day2)))))) -(defun ledger-schedule-is-holiday (date) - "Return true if DATE is a holiday.") (defun ledger-schedule-scan-transactions (schedule-file) - "Scans AUTO_FILE and returns a list of transactions with date predicates. -The car of each item is a fuction of date that returns true if + "Scan SCHEDULE-FILE and return a list of transactions with date predicates. +The car of each item is a function of date that returns true if the transaction should be logged for that day." (interactive "fFile name: ") (let ((xact-list (list))) (with-current-buffer - (find-file-noselect schedule-file) + (find-file-noselect schedule-file) (goto-char (point-min)) (while (re-search-forward "^\\[\\(.*\\)\\] " nil t) - (let ((date-descriptor "") - (transaction nil) - (xact-start (match-end 0))) - (setq date-descriptors - (ledger-schedule-read-descriptor-tree - (buffer-substring-no-properties - (match-beginning 0) - (match-end 0)))) - (forward-paragraph) - (setq transaction (list date-descriptors - (buffer-substring-no-properties - xact-start - (point)))) - (setq xact-list (cons transaction xact-list)))) - xact-list))) - -(defun ledger-schedule-replace-brackets () - "Replace all brackets with parens" - (goto-char (point-min)) - (while (search-forward "]" nil t) - (replace-match ")" nil t)) - (goto-char (point-min)) - (while (search-forward "[" nil t) - (replace-match "(" nil t))) - -(defvar ledger-schedule-descriptor-regex - (concat "\\(20[0-9][0-9]\\|[\*]\\)[/\\-]" ;; Year slot - "\\([\*EO]\\|[01][0-9]\\)[/\\-]" ;; Month slot - "\\([\*]\\|\\([0-3][0-9]\\)\\|" - "\\([0-5]" - "\\(\\(Su\\)\\|" - "\\(Mo\\)\\|" - "\\(Tu\\)\\|" - "\\(We\\)\\|" - "\\(Th\\)\\|" - "\\(Fr\\)\\|" - "\\(Sa\\)\\)\\)\\)")) + (let ((date-descriptor "") + (transaction nil) + (xact-start (match-end 0))) + (setq date-descriptor + (ledger-schedule-read-descriptor-tree + (buffer-substring-no-properties + (match-beginning 0) + (match-end 0)))) + (forward-paragraph) + (setq transaction (list date-descriptor + (buffer-substring-no-properties + xact-start + (point)))) + (setq xact-list (cons transaction xact-list)))) + xact-list))) (defun ledger-schedule-read-descriptor-tree (descriptor-string) - "Take a date DESCRIPTOR-STRING and return a function of date that -returns true if the date meets the requirements" - (with-temp-buffer - ;; copy the descriptor string into a temp buffer for manipulation - (let (pos) - ;; Replace brackets with parens - (insert descriptor-string) - (ledger-schedule-replace-brackets) - - (goto-char (point-max)) - ;; double quote all the descriptors for string processing later - (while (re-search-backward ledger-schedule-descriptor-regex nil t) ;; Day slot - (goto-char - (match-end 0)) - (insert ?\") - (goto-char (match-beginning 0)) - (insert "\"" ))) - - ;; read the descriptor string into a lisp object the transform the - ;; string descriptor into useable things - (ledger-schedule-transform-auto-tree - (read (buffer-substring-no-properties (point-min) (point-max)))))) + "Read DESCRIPTOR-STRING and return a form that evaluates dates." + (ledger-schedule-transform-auto-tree + (split-string + (substring descriptor-string 1 (string-match "]" descriptor-string)) " "))) (defun ledger-schedule-transform-auto-tree (descriptor-string-list) -"Takes a lisp list of date descriptor strings, TREE, and returns a string with a lambda function of date." -;; use funcall to use the lambda function spit out here + "Take DESCRIPTOR-STRING-LIST, and return a string with a lambda function of date." + ;; use funcall to use the lambda function spit out here (if (consp descriptor-string-list) (let (result) - (while (consp descriptor-string-list) - (let ((newcar (car descriptor-string-list))) - (if (consp newcar) - (setq newcar (ledger-schedule-transform-auto-tree (car descriptor-string-list)))) - ;; newcar may be a cons now, after ledger-schedule-transfrom-auto-tree - (if (consp newcar) - (push newcar result) - ;; this is where we actually turn the string descriptor into useful lisp - (push (ledger-schedule-compile-constraints newcar) result)) ) - (setq descriptor-string-list (cdr descriptor-string-list))) - - ;; tie up all the clauses in a big or and lambda, and return - ;; the lambda function as list to be executed by funcall - `(lambda (date) - ,(nconc (list 'or) (nreverse result) descriptor-string-list))))) + (while (consp descriptor-string-list) + (let ((newcar (car descriptor-string-list))) + (if (consp newcar) + (setq newcar (ledger-schedule-transform-auto-tree (car descriptor-string-list)))) + ;; newcar may be a cons now, after ledger-schedule-transfrom-auto-tree + (if (consp newcar) + (push newcar result) + ;; this is where we actually turn the string descriptor into useful lisp + (push (ledger-schedule-compile-constraints newcar) result)) ) + (setq descriptor-string-list (cdr descriptor-string-list))) + + ;; tie up all the clauses in a big or lambda, and return + ;; the lambda function as list to be executed by funcall + `(lambda (date) + ,(nconc (list 'or) (nreverse result) descriptor-string-list))))) (defun ledger-schedule-compile-constraints (descriptor-string) - "Return a list with the year, month and day fields split" - (let ((fields (split-string descriptor-string "[/\\-]" t)) - constrain-year constrain-month constrain-day) - (setq constrain-year (ledger-schedule-constrain-year (nth 0 fields))) - (setq constrain-month (ledger-schedule-constrain-month (nth 1 fields))) - (setq constrain-day (ledger-schedule-constrain-day (nth 2 fields))) - - (list 'and constrain-year constrain-month constrain-day))) - -(defun ledger-schedule-constrain-year (str) - (let ((year-match t)) - (cond ((string= str "*") - year-match) - ((/= 0 (setq year-match (string-to-number str))) - `(eq (nth 5 (decode-time date)) ,year-match)) - (t - (error "Improperly specified year constraint: " str))))) - -(defun ledger-schedule-constrain-month (str) - - (let ((month-match t)) - (cond ((string= str "*") - month-match) ;; always match - ((/= 0 (setq month-match (string-to-number str))) - (if (between month-match 1 12) ;; no month specified, assume 31 days. - `(eq (nth 4 (decode-time date)) ,month-match) - (error "ledger-schedule-constrain-numerical-month: month out of range %S" month-match))) - (t - (error "Improperly specified month constraint: " str))))) - -(defun ledger-schedule-constrain-day (str) - (let ((day-match t)) - (cond ((string= str "*") - t) - ((/= 0 (setq day-match (string-to-number str))) - `(eq (nth 3 (decode-time date)) ,day-match)) - (t - (error "Improperly specified day constraint: " str))))) - -(defun ledger-schedule-parse-date-descriptor (descriptor) - "Parse the date descriptor, return the evaluator" - (ledger-schedule-compile-constraints descriptor)) + "Return a list with the year, month and day fields split." + (let ((fields (split-string descriptor-string "[/\\-]" t))) + (if (string-match "[A-Za-z]" descriptor-string) + (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields)) + (list 'and + (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields)) + (ledger-schedule-constrain-year (nth 0 fields) (nth 1 fields) (nth 2 fields)) + (ledger-schedule-constrain-month (nth 0 fields) (nth 1 fields) (nth 2 fields)))))) + +(defun ledger-schedule-constrain-year (year-desc month-desc day-desc) + "Return a form that constrains the year. + +YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the +date descriptor." + (cond ((string= year-desc "*") t) + ((/= 0 (string-to-number year-desc)) + `(memq (nth 5 (decode-time date)) ',(mapcar 'string-to-number (split-string year-desc ",")))) + (t + (error "Improperly specified year constraint: %s %s %s" year-desc month-desc day-desc)))) + +(defun ledger-schedule-constrain-month (year-desc month-desc day-desc) + "Return a form that constrains the month. + +YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the +date descriptor." + (cond ((string= month-desc "*") + t) ;; always match + ((string= month-desc "E") ;; Even + `(evenp (nth 4 (decode-time date)))) + ((string= month-desc "O") ;; Odd + `(oddp (nth 4 (decode-time date)))) + ((/= 0 (string-to-number month-desc)) ;; Starts with number + `(memq (nth 4 (decode-time date)) ',(mapcar 'string-to-number (split-string month-desc ",")))) + (t + (error "Improperly specified month constraint: %s %s %s" year-desc month-desc day-desc)))) + +(defun ledger-schedule-constrain-day (year-desc month-desc day-desc) + "Return a form that constrains the day. + +YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the +date descriptor." + (cond ((string= day-desc "*") + t) + ((string-match "[A-Za-z]" day-desc) ;; There is something other than digits and commas + (ledger-schedule-parse-complex-date year-desc month-desc day-desc)) + ((/= 0 (string-to-number day-desc)) + `(memq (nth 3 (decode-time date)) ',(mapcar 'string-to-number (split-string day-desc ",")))) + (t + (error "Improperly specified day constraint: %s %s %s" year-desc month-desc day-desc)))) + + + +(defun ledger-schedule-parse-complex-date (year-desc month-desc day-desc) + "Parse day descriptors that have repeats." + (let ((years (mapcar 'string-to-number (split-string year-desc ","))) + (months (mapcar 'string-to-number (split-string month-desc ","))) + (day-parts (split-string day-desc "+")) + (every-nth (string-match "+" day-desc))) + (if every-nth + (let ((base-day (string-to-number (car day-parts))) + (increment (string-to-number (substring (cadr day-parts) 0 + (string-match "[A-Za-z]" (cadr day-parts))))) + (day-of-week (ledger-schedule-encode-day-of-week + (substring (cadr day-parts) (string-match "[A-Za-z]" (cadr day-parts)))))) + (ledger-schedule-constrain-every-count-day day-of-week increment (encode-time 0 0 0 base-day (car months) (car years)))) + (let ((count (string-to-number (substring (car day-parts) 0 1))) + (day-of-week (ledger-schedule-encode-day-of-week + (substring (car day-parts) (string-match "[A-Za-z]" (car day-parts)))))) + (ledger-schedule-constrain-day-in-month count day-of-week))))) (defun ledger-schedule-list-upcoming-xacts (candidate-items early horizon) - "Search CANDIDATE-ITEMS for xacts that occur within the period today - EARLY to today + HORIZON" - (let ((start-date (time-subtract (current-time) (days-to-time early))) - test-date items) - (loop for day from 0 to (+ early horizon) by 1 do - (setq test-date (time-add start-date (days-to-time day))) - (dolist (candidate candidate-items items) - (if (funcall (car candidate) test-date) - (setq items (append items (list (list test-date (cadr candidate)))))))) - items)) - -(defun ledger-schedule-already-entered (candidate buffer) - (let ((target-date (format-time-string date-format (car candidate))) - (target-payee (cadr candidate))) - nil)) + "Search CANDIDATE-ITEMS for xacts that occur within the period today - EARLY to today + HORIZON." + (let ((start-date (time-subtract (current-time) (days-to-time early))) + test-date items) + (loop for day from 0 to (+ early horizon) by 1 do + (setq test-date (time-add start-date (days-to-time day))) + (dolist (candidate candidate-items items) + (if (funcall (car candidate) test-date) + (setq items (append items (list (list test-date (cadr candidate)))))))) + items)) (defun ledger-schedule-create-auto-buffer (candidate-items early horizon ledger-buf) "Format CANDIDATE-ITEMS for display." (let ((candidates (ledger-schedule-list-upcoming-xacts candidate-items early horizon)) - (schedule-buf (get-buffer-create ledger-schedule-buffer-name)) - (date-format (cdr (assoc "date-format" ledger-environment-alist)))) + (schedule-buf (get-buffer-create ledger-schedule-buffer-name)) + (date-format (or (cdr (assoc "date-format" ledger-environment-alist)) + ledger-default-date-format))) (with-current-buffer schedule-buf (erase-buffer) - (dolist (candidate candidates) - (if (not (ledger-schedule-already-entered candidate ledger-buf)) - (insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n"))) - (ledger-mode)) + (dolist (candidate candidates) + (insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n")) + (ledger-mode)) (length candidates))) - -;; -;; Test harnesses for use in ielm -;; -(defvar auto-items) - -(defun ledger-schedule-test ( early horizon) - (ledger-schedule-create-auto-buffer - (ledger-schedule-scan-transactions ledger-schedule-file) - early - horizon - (get-buffer "2013.ledger"))) - - -(defun ledger-schedule-test-predict () - (let ((today (current-time)) - test-date items) - - (loop for day from 0 to ledger-schedule-look-forward by 1 do - (setq test-date (time-add today (days-to-time day))) - (dolist (item auto-items items) - (if (funcall (car item) test-date) - (setq items (append items (list (decode-time test-date) (cdr item))))))) - items)) - -(defun ledger-schedule-upcoming () - (interactive) - (ledger-schedule-create-auto-buffer - (ledger-schedule-scan-transactions ledger-schedule-file) - ledger-schedule-look-backward - ledger-schedule-look-forward - (current-buffer))) +(defun ledger-schedule-upcoming (file look-backward look-forward) + "Generate upcoming transactions. + +FILE is the file containing the scheduled transaction, +default to `ledger-schedule-file'. +LOOK-BACKWARD is the number of day in the past to look at +default to `ledger-schedule-look-backward' +LOOK-FORWARD is the number of day in the futur to look at +default to `ledger-schedule-look-forward' + +Use a prefix arg to change the default value" + (interactive (if current-prefix-arg + (list (read-file-name "Schedule File: " () ledger-schedule-file t) + (read-number "Look backward: " ledger-schedule-look-backward) + (read-number "Look forward: " ledger-schedule-look-forward)) + (list ledger-schedule-file ledger-schedule-look-backward ledger-schedule-look-forward))) + (if (and file + (file-exists-p file)) + (progn + (ledger-schedule-create-auto-buffer + (ledger-schedule-scan-transactions file) + look-backward + look-forward + (current-buffer)) + (pop-to-buffer ledger-schedule-buffer-name)) + (error "Could not find ledger schedule file at %s" file))) (provide 'ledger-schedule) diff --git a/lisp/ledger-sort.el b/lisp/ledger-sort.el index c5a41952..870e298c 100644 --- a/lisp/ledger-sort.el +++ b/lisp/ledger-sort.el @@ -1,6 +1,6 @@ ;;; ledger-xact.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. @@ -26,39 +26,34 @@ ;;; Code: -(defun ledger-next-record-function () - "Move point to next transaction." - (if (re-search-forward ledger-payee-any-status-regex nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max)))) - -(defun ledger-end-record-function () - "Move point to end of transaction." - (forward-paragraph)) (defun ledger-sort-find-start () + "Find the beginning of a sort region" (if (re-search-forward ";.*Ledger-mode:.*Start sort" nil t) (match-end 0))) (defun ledger-sort-find-end () + "Find the end of a sort region" (if (re-search-forward ";.*Ledger-mode:.*End sort" nil t) (match-end 0))) (defun ledger-sort-insert-start-mark () + "Insert a marker to start a sort region" (interactive) (save-excursion (goto-char (point-min)) (if (ledger-sort-find-start) - (delete-region (match-beginning 0) (match-end 0)))) + (delete-region (match-beginning 0) (match-end 0)))) (beginning-of-line) (insert "\n; Ledger-mode: Start sort\n\n")) (defun ledger-sort-insert-end-mark () + "Insert a marker to end a sort region" (interactive) (save-excursion (goto-char (point-min)) (if (ledger-sort-find-end) - (delete-region (match-beginning 0) (match-end 0)))) + (delete-region (match-beginning 0) (match-end 0)))) (beginning-of-line) (insert "\n; Ledger-mode: End sort\n\n")) @@ -69,57 +64,59 @@ (defun ledger-sort-region (beg end) "Sort the region from BEG to END in chronological order." (interactive "r") ;; load beg and end from point and mark - ;; automagically + ;; automagically (let ((new-beg beg) - (new-end end) - point-delta - (bounds (ledger-find-xact-extents (point))) - target-xact) - - (setq point-delta (- (point) (car bounds))) - (setq target-xact (buffer-substring (car bounds) (cadr bounds))) - (setq inhibit-modification-hooks t) + (new-end end) + point-delta + (bounds (ledger-navigate-find-xact-extents (point))) + target-xact) + + (setq point-delta (- (point) (car bounds))) + (setq target-xact (buffer-substring (car bounds) (cadr bounds))) + (setq inhibit-modification-hooks t) (save-excursion (save-restriction - (goto-char beg) - (ledger-next-record-function) ;; make sure point is at the - ;; beginning of a xact - (setq new-beg (point)) - (goto-char end) - (ledger-next-record-function) ;; make sure end of region is at - ;; the beginning of next record - ;; after the region - (setq new-end (point)) - (narrow-to-region new-beg new-end) - (goto-char new-beg) - - (let ((inhibit-field-text-motion t)) - (sort-subr - nil - 'ledger-next-record-function - 'ledger-end-record-function - 'ledger-sort-startkey)))) - - (goto-char (point-min)) - (re-search-forward (regexp-quote target-xact)) - (goto-char (+ (match-beginning 0) point-delta)) + (goto-char beg) + ;; make sure point is at the beginning of a xact + (ledger-navigate-next-xact) + (unless (looking-at ledger-payee-any-status-regex) + (ledger-navigate-next-xact)) + (setq new-beg (point)) + (goto-char end) + (ledger-navigate-next-xact) + ;; make sure end of region is at the beginning of next record + ;; after the region + (setq new-end (point)) + (narrow-to-region new-beg new-end) + (goto-char new-beg) + + (let ((inhibit-field-text-motion t)) + (sort-subr + nil + 'ledger-navigate-next-xact + 'ledger-navigate-end-of-xact + 'ledger-sort-startkey)))) + + (goto-char (point-min)) + (re-search-forward (regexp-quote target-xact)) + (goto-char (+ (match-beginning 0) point-delta)) (setq inhibit-modification-hooks nil))) (defun ledger-sort-buffer () "Sort the entire buffer." (interactive) (let (sort-start - sort-end) - (save-excursion - (goto-char (point-min)) - (setq sort-start (ledger-sort-find-start) - sort-end (ledger-sort-find-end))) + sort-end) + (save-excursion + (goto-char (point-min)) + (setq sort-start (ledger-sort-find-start) + sort-end (ledger-sort-find-end))) (ledger-sort-region (if sort-start - sort-start - (point-min)) - (if sort-end - sort-end - (point-max))))) + sort-start + (point-min)) + (if sort-end + sort-end + (point-max))))) (provide 'ledger-sort) diff --git a/lisp/ledger-state.el b/lisp/ledger-state.el index 121e97ca..47805f15 100644 --- a/lisp/ledger-state.el +++ b/lisp/ledger-state.el @@ -1,6 +1,6 @@ ;;; ledger-state.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: @@ -54,16 +54,26 @@ "Return the char representation of STATE." (if state (if (eq state 'pending) - "!" - "*") - "")) + "!" + "*") + "")) (defun ledger-state-from-char (state-char) "Get state from STATE-CHAR." (cond ((eql state-char ?\!) 'pending) - ((eql state-char ?\*) 'cleared) - ((eql state-char ?\;) 'comment) - (t nil))) + ((eql state-char ?\*) 'cleared) + ((eql state-char ?\;) 'comment) + (t nil))) + + +(defun ledger-state-from-string (state-string) + "Get state from STATE-CHAR." + (when state-string + (cond + ((string-match "\\!" state-string) 'pending) + ((string-match "\\*" state-string) 'cleared) + ((string-match ";" state-string) 'comment) + (t nil)))) (defun ledger-toggle-current-posting (&optional style) "Toggle the cleared status of the transaction under point. @@ -77,16 +87,17 @@ achieved more certainly by passing the xact to ledger for formatting, but doing so causes inline math expressions to be dropped." (interactive) - (let ((bounds (ledger-find-xact-extents (point))) + (let ((bounds (ledger-navigate-find-xact-extents (point))) new-status cur-status) ;; Uncompact the xact, to make it easier to toggle the ;; transaction (save-excursion ;; this excursion checks state of entire - ;; transaction and unclears if marked + ;; transaction and unclears if marked (goto-char (car bounds)) ;; beginning of xact - (skip-chars-forward "0-9./=\\- \t") ;; skip the date + (skip-chars-forward "0-9./=\\-") ;; skip the date + (skip-chars-forward " \t") ;; skip the white space after the date (setq cur-status (and (member (char-after) '(?\* ?\!)) - (ledger-state-from-char (char-after)))) + (ledger-state-from-char (char-after)))) ;;if cur-status if !, or * then delete the marker (when cur-status (let ((here (point))) @@ -97,15 +108,16 @@ dropped." (if (search-forward " " (line-end-position) t) (insert (make-string width ? )))))) (forward-line) - ;; Shift the cleared/pending status to the postings + ;; Shift the cleared/pending status to the postings (while (looking-at "[ \t]") (skip-chars-forward " \t") - (when (not (eq (ledger-state-from-char (char-after)) 'comment)) - (insert (ledger-char-from-state cur-status) " ") - (if (search-forward " " (line-end-position) t) - (delete-char 2))) - (forward-line)) - (setq new-status nil))) + (when (not (eq (ledger-state-from-char (char-after)) 'comment)) + (insert (ledger-char-from-state cur-status) " ") + (if (and (search-forward " " (line-end-position) t) + (looking-at " ")) + (delete-char 2))) + (forward-line)) + (setq new-status nil))) ;;this excursion toggles the posting status (save-excursion @@ -113,40 +125,40 @@ dropped." (goto-char (line-beginning-position)) (when (looking-at "[ \t]") - (skip-chars-forward " \t") - (let ((here (point)) - (cur-status (ledger-state-from-char (char-after)))) - (skip-chars-forward "*! ") - (let ((width (- (point) here))) - (when (> width 0) - (delete-region here (point)) - (save-excursion - (if (search-forward " " (line-end-position) t) - (insert (make-string width ? )))))) - (let (inserted) - (if cur-status - (if (and style (eq style 'cleared)) - (progn - (insert "* ") - (setq inserted 'cleared))) - (if (and style (eq style 'pending)) - (progn - (insert "! ") - (setq inserted 'pending)) - (progn - (insert "* ") - (setq inserted 'cleared)))) - (if (and inserted - (re-search-forward "\\(\t\\| [ \t]\\)" - (line-end-position) t)) - (cond - ((looking-at "\t") - (delete-char 1)) - ((looking-at " [ \t]") - (delete-char 2)) - ((looking-at " ") - (delete-char 1)))) - (setq new-status inserted)))) + (skip-chars-forward " \t") + (let ((here (point)) + (cur-status (ledger-state-from-char (char-after)))) + (skip-chars-forward "*! ") + (let ((width (- (point) here))) + (when (> width 0) + (delete-region here (point)) + (save-excursion + (if (search-forward " " (line-end-position) t) + (insert (make-string width ? )))))) + (let (inserted) + (if cur-status + (if (and style (eq style 'cleared)) + (progn + (insert "* ") + (setq inserted 'cleared))) + (if (and style (eq style 'pending)) + (progn + (insert "! ") + (setq inserted 'pending)) + (progn + (insert "* ") + (setq inserted 'cleared)))) + (if (and inserted + (re-search-forward "\\(\t\\| [ \t]\\)" + (line-end-position) t)) + (cond + ((looking-at "\t") + (delete-char 1)) + ((looking-at " [ \t]") + (delete-char 2)) + ((looking-at " ") + (delete-char 1)))) + (setq new-status inserted)))) (setq inhibit-modification-hooks nil)) ;; This excursion cleans up the xact so that it displays @@ -161,12 +173,12 @@ dropped." (while (and (not hetero) (looking-at "[ \t]")) (skip-chars-forward " \t") (let ((cur-status (ledger-state-from-char (char-after)))) - (if (not (eq cur-status 'comment)) - (if first - (setq state cur-status - first nil) - (if (not (eq state cur-status)) - (setq hetero t))))) + (if (not (eq cur-status 'comment)) + (if first + (setq state cur-status + first nil) + (if (not (eq state cur-status)) + (setq hetero t))))) (forward-line)) (when (and (not hetero) (not (eq state nil))) (goto-char (car bounds)) @@ -183,18 +195,19 @@ dropped." (insert (make-string width ? )))))) (forward-line)) (goto-char (car bounds)) - (skip-chars-forward "0-9./=\\- \t") + (skip-chars-forward "0-9./=\\-") ;; Skip the date + (skip-chars-forward " \t") ;; Skip the white space (insert (ledger-char-from-state state) " ") - (setq new-status state) + (setq new-status state) (if (re-search-forward "\\(\t\\| [ \t]\\)" (line-end-position) t) (cond - ((looking-at "\t") - (delete-char 1)) - ((looking-at " [ \t]") - (delete-char 2)) - ((looking-at " ") - (delete-char 1))))))) + ((looking-at "\t") + (delete-char 1)) + ((looking-at " [ \t]") + (delete-char 2)) + ((looking-at " ") + (delete-char 1))))))) new-status)) (defun ledger-toggle-current (&optional style) @@ -214,30 +227,30 @@ dropped." (forward-line) (goto-char (line-beginning-position)))) (ledger-toggle-current-transaction style)) - (ledger-toggle-current-posting style))) + (ledger-toggle-current-posting style))) (defun ledger-toggle-current-transaction (&optional style) "Toggle the transaction at point using optional STYLE." (interactive) (save-excursion (when (or (looking-at "^[0-9]") - (re-search-backward "^[0-9]" nil t)) + (re-search-backward "^[0-9]" nil t)) (skip-chars-forward "0-9./=\\-") (delete-horizontal-space) (if (or (eq (ledger-state-from-char (char-after)) 'pending) - (eq (ledger-state-from-char (char-after)) 'cleared)) - (progn - (delete-char 1) - (when (and style (eq style 'cleared)) - (insert " *") - 'cleared)) - (if (and style (eq style 'pending)) - (progn - (insert " ! ") - 'pending) - (progn - (insert " * ") - 'cleared)))))) + (eq (ledger-state-from-char (char-after)) 'cleared)) + (progn + (delete-char 1) + (when (and style (eq style 'cleared)) + (insert " *") + 'cleared)) + (if (and style (eq style 'pending)) + (progn + (insert " ! ") + 'pending) + (progn + (insert " * ") + 'cleared)))))) (provide 'ledger-state) diff --git a/lisp/ledger-test.el b/lisp/ledger-test.el index a275ae7f..da120f63 100644 --- a/lisp/ledger-test.el +++ b/lisp/ledger-test.el @@ -1,6 +1,6 @@ ;;; ledger-test.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,18 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. + +;;; Commentary: + +;;; Code: + +(declare-function ledger-mode "ledger-mode") ; TODO: fix this cyclic dependency +(declare-function org-narrow-to-subtree "org") +(declare-function org-entry-get "org") +(declare-function outline-back-to-heading "outline") +(declare-function outline-next-heading "outline") (defgroup ledger-test nil "Definitions for the Ledger testing framework" @@ -98,9 +108,9 @@ (ledger-mode) (if input (insert input) - (insert "2012-03-17 Payee\n") - (insert " Expenses:Food $20\n") - (insert " Assets:Cash\n")) + (insert "2012-03-17 Payee\n") + (insert " Expenses:Food $20\n") + (insert " Assets:Cash\n")) (insert "\ntest reg\n") (if output (insert output)) @@ -121,7 +131,9 @@ (let ((prev-directory default-directory)) (cd ledger-source-directory) (unwind-protect - (async-shell-command (format "\"%s\" %s" command args)) + (async-shell-command (format "\"%s\" %s" command args)) (cd prev-directory))))))) (provide 'ledger-test) + +;;; ledger-test.el ends here diff --git a/lisp/ledger-texi.el b/lisp/ledger-texi.el index 68880550..afaf0df7 100644 --- a/lisp/ledger-texi.el +++ b/lisp/ledger-texi.el @@ -1,6 +1,6 @@ ;;; ledger-texi.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,22 +16,22 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. (defgroup ledger-texi nil -"Options for working on Ledger texi documentation" -:group 'ledger) + "Options for working on Ledger texi documentation" + :group 'ledger) (defcustom ledger-texi-sample-doc-path "~/ledger/doc/sample.dat" -"Location for sample data to be used in texi tests" -:type 'file -:group 'ledger-texi) + "Location for sample data to be used in texi tests" + :type 'file + :group 'ledger-texi) (defcustom ledger-texi-normalization-args "--args-only --columns 80" -"texi normalization for producing ledger output" -:type 'string -:group 'ledger-texi) + "texi normalization for producing ledger output" + :type 'string + :group 'ledger-texi) (defun ledger-update-test () (interactive) @@ -104,17 +104,17 @@ (if (string-match "\\$LEDGER" command) (replace-match (format "%s -f \"%s\" %s" ledger-binary-path data-file ledger-texi-normalization-args) t t command) - (concat (format "%s -f \"%s\" %s " ledger-binary-path - data-file ledger-texi-normalization-args) command))) + (concat (format "%s -f \"%s\" %s " ledger-binary-path + data-file ledger-texi-normalization-args) command))) (defun ledger-texi-invoke-command (command) (with-temp-buffer (shell-command command t (current-buffer)) - (if (= (point-min) (point-max)) - (progn - (push-mark nil t) - (message "Command '%s' yielded no result at %d" command (point)) - (ding)) - (buffer-string)))) + (if (= (point-min) (point-max)) + (progn + (push-mark nil t) + (message "Command '%s' yielded no result at %d" command (point)) + (ding)) + (buffer-string)))) (defun ledger-texi-write-test-data (name input) (let ((path (expand-file-name name temporary-file-directory))) @@ -159,7 +159,7 @@ (let ((section-name (if (string= section "smex") "smallexample" - "example")) + "example")) (output (ledger-texi-invoke-command (ledger-texi-expand-command command data-file)))) (insert "@" section-name ?\n output diff --git a/lisp/ledger-xact.el b/lisp/ledger-xact.el index e6269580..0eb9386a 100644 --- a/lisp/ledger-xact.el +++ b/lisp/ledger-xact.el @@ -1,6 +1,6 @@ ;;; ledger-xact.el --- Helper code for use with the "ledger" command-line tool -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) +;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org) ;; This file is not part of GNU Emacs. @@ -16,8 +16,8 @@ ;; ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. ;;; Commentary: @@ -25,6 +25,11 @@ ;;; Code: +(require 'eshell) +(require 'ledger-regex) +(require 'ledger-navigate) +;; TODO: This file depends on code in ledger-mode.el, which depends on this. + (defcustom ledger-highlight-xact-under-point t "If t highlight xact under point." :type 'boolean @@ -36,38 +41,23 @@ :group 'ledger :safe t) -(defvar highlight-overlay (list)) - -(defun ledger-find-xact-extents (pos) - "Return point for beginning of xact and and of xact containing position. -Requires empty line separating xacts. Argument POS is a location -within the transaction." - (interactive "d") - (save-excursion - (goto-char pos) - (list (progn - (backward-paragraph) - (if (/= (point) (point-min)) - (forward-line)) - (line-beginning-position)) - (progn - (forward-paragraph) - (line-beginning-position))))) +(defvar ledger-xact-highlight-overlay (list)) +(make-variable-buffer-local 'ledger-xact-highlight-overlay) (defun ledger-highlight-xact-under-point () "Move the highlight overlay to the current transaction." (if ledger-highlight-xact-under-point - (let ((exts (ledger-find-xact-extents (point))) - (ovl highlight-overlay)) - (if (not highlight-overlay) - (setq ovl - (setq highlight-overlay - (make-overlay (car exts) - (cadr exts) - (current-buffer) t nil))) - (move-overlay ovl (car exts) (cadr exts))) - (overlay-put ovl 'face 'ledger-font-xact-highlight-face) - (overlay-put ovl 'priority 100)))) + (let ((exts (ledger-navigate-find-element-extents (point))) + (ovl ledger-xact-highlight-overlay)) + (if (not ledger-xact-highlight-overlay) + (setq ovl + (setq ledger-xact-highlight-overlay + (make-overlay (car exts) + (cadr exts) + (current-buffer) t nil))) + (move-overlay ovl (car exts) (cadr exts))) + (overlay-put ovl 'face 'ledger-font-xact-highlight-face) + (overlay-put ovl 'priority '(nil . 99))))) (defun ledger-xact-payee () "Return the payee of the transaction containing point or nil." @@ -77,7 +67,7 @@ within the transaction." (let ((context-info (ledger-context-other-line i))) (if (eq (ledger-context-line-type context-info) 'xact) (ledger-context-field-value context-info 'payee) - nil)))) + nil)))) (defun ledger-time-less-p (t1 t2) "Say whether time value T1 is less than time value T2." @@ -88,12 +78,20 @@ within the transaction." (defun ledger-xact-find-slot (moment) "Find the right place in the buffer for a transaction at MOMENT. MOMENT is an encoded date" - (catch 'found - (ledger-xact-iterate-transactions - (function - (lambda (start date mark desc) - (if (ledger-time-less-p moment date) - (throw 'found t))))))) + (let (last-xact-start) + (catch 'found + (ledger-xact-iterate-transactions + (function + (lambda (start date mark desc) + (setq last-xact-start start) + (if (ledger-time-less-p moment date) + (throw 'found t)))))) + (when (and (eobp) last-xact-start) + (let ((end (cadr (ledger-navigate-find-xact-extents last-xact-start)))) + (goto-char end) + (if (eobp) + (insert "\n") + (forward-line)))))) (defun ledger-xact-iterate-transactions (callback) "Iterate through each transaction call CALLBACK for each." @@ -105,49 +103,43 @@ MOMENT is an encoded date" (let ((found-y-p (match-string 2))) (if found-y-p (setq current-year (string-to-number found-y-p)) ;; a Y directive was found - (let ((start (match-beginning 0)) - (year (match-string 4)) - (month (string-to-number (match-string 5))) - (day (string-to-number (match-string 6))) - (mark (match-string 7)) - (code (match-string 8)) - (desc (match-string 9))) - (if (and year (> (length year) 0)) - (setq year (string-to-number year))) - (funcall callback start - (encode-time 0 0 0 day month - (or year current-year)) - mark desc))))) + (let ((start (match-beginning 0)) + (year (match-string 4)) + (month (string-to-number (match-string 5))) + (day (string-to-number (match-string 6))) + (mark (match-string 7)) + (code (match-string 8)) + (desc (match-string 9))) + (if (and year (> (length year) 0)) + (setq year (string-to-number year))) + (funcall callback start + (encode-time 0 0 0 day month + (or year current-year)) + mark desc))))) (forward-line)))) -(defsubst ledger-goto-line (line-number) - "Rapidly move point to line LINE-NUMBER." - (goto-char (point-min)) - (forward-line (1- line-number))) - (defun ledger-year-and-month () (let ((sep (if ledger-use-iso-dates "-" "/"))) - (concat ledger-year sep ledger-month sep))) + (concat ledger-year sep ledger-month sep))) (defun ledger-copy-transaction-at-point (date) "Ask for a new DATE and copy the transaction under point to that date. Leave point on the first amount." (interactive (list - (read-string "Copy to date: " (ledger-year-and-month) - 'ledger-minibuffer-history))) + (ledger-read-date "Copy to date: "))) (let* ((here (point)) - (extents (ledger-find-xact-extents (point))) - (transaction (buffer-substring-no-properties (car extents) (cadr extents))) - encoded-date) + (extents (ledger-navigate-find-xact-extents (point))) + (transaction (buffer-substring-no-properties (car extents) (cadr extents))) + encoded-date) (if (string-match ledger-iso-date-regexp date) - (setq encoded-date - (encode-time 0 0 0 (string-to-number (match-string 4 date)) - (string-to-number (match-string 3 date)) - (string-to-number (match-string 2 date))))) + (setq encoded-date + (encode-time 0 0 0 (string-to-number (match-string 4 date)) + (string-to-number (match-string 3 date)) + (string-to-number (match-string 2 date))))) (ledger-xact-find-slot encoded-date) (insert transaction "\n") - (backward-paragraph 2) + (ledger-navigate-beginning-of-xact) (re-search-forward ledger-iso-date-regexp) (replace-match date) (ledger-next-amount) @@ -155,18 +147,20 @@ MOMENT is an encoded date" (goto-char (match-beginning 0))))) (defun ledger-delete-current-transaction (pos) - "Delete the transaction surrounging point." + "Delete the transaction surrounging POS." (interactive "d") - (let ((bounds (ledger-find-xact-extents pos))) + (let ((bounds (ledger-navigate-find-xact-extents pos))) (delete-region (car bounds) (cadr bounds)))) (defun ledger-add-transaction (transaction-text &optional insert-at-point) "Use ledger xact TRANSACTION-TEXT to add a transaction to the buffer. -If INSERT-AT-POINT is non-nil insert the transaction -there, otherwise call `ledger-xact-find-slot' to insert it at the +If INSERT-AT-POINT is non-nil insert the transaction there, +otherwise call `ledger-xact-find-slot' to insert it at the correct chronological place in the buffer." (interactive (list - (read-string "Transaction: " (ledger-year-and-month)))) + ;; Note: This isn't "just" the date - it can contain + ;; other text too + (ledger-read-date "Transaction: "))) (let* ((args (with-temp-buffer (insert transaction-text) (eshell-parse-arguments (point-min) (point-max)))) @@ -181,21 +175,21 @@ correct chronological place in the buffer." (string-to-number (match-string 2 date))))) (ledger-xact-find-slot date))) (if (> (length args) 1) - (save-excursion - (insert - (with-temp-buffer - (setq exit-code - (apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact" - (mapcar 'eval args))) - (goto-char (point-min)) - (if (looking-at "Error: ") - (error (concat "Error in ledger-add-transaction: " (buffer-string))) - (buffer-string))) - "\n")) - (progn - (insert (car args) " \n\n") - (end-of-line -1))))) - + (save-excursion + (insert + (with-temp-buffer + (setq exit-code + (apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact" + (mapcar 'eval args))) + (goto-char (point-min)) + (if (looking-at "Error: ") + (error (concat "Error in ledger-add-transaction: " (buffer-string))) + (ledger-post-align-postings (point-min) (point-max)) + (buffer-string))) + "\n")) + (progn + (insert (car args) " \n\n") + (end-of-line -1))))) (provide 'ledger-xact) |