daniel/emacs
1
2
Fork 0
Code Issues 7 Pull Requests Projects Releases Wiki Activity

add lisp packages

Browse Source
This commit is contained in:
Daniel Weschke
2020-12-05 21:29:49 +01:00
parent 85e20365ae
commit a6e2395755
7272 changed files with 1363243 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
lisp/ledger-mode/dir Normal file
View File

@@ -0,0 +1,18 @@
This is the file .../info/dir, which contains the
topmost node of the Info hierarchy, called (dir)Top.
The first time you invoke Info you start off looking at this node.

File: dir, Node: Top This is the top of the INFO tree
This (the Directory node) gives a menu of major topics.
Typing "q" exits, "H" lists all Info commands, "d" returns here,
"h" gives a primer for first-timers,
"mEmacs<Return>" visits the Emacs manual, etc.
In Emacs, you can click mouse button 2 on a menu item or cross reference
to select it.
* Menu:
Emacs
* Ledger Mode: (ledger-mode). Command-Line Accounting

143
lisp/ledger-mode/ledger-check.el Normal file
View File

@@ -0,0 +1,143 @@
;;; ledger-check.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 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:
;; Provide secial mode to correct errors in ledger when running with --strict and --explicit
;;
;; Adapted to ledger mode by Craig Earls <enderw88 at gmail dot com>
;;; Code:
(require 'easymenu)
(require 'ledger-navigate)
(require 'ledger-report) ; for ledger-master-file
(defvar ledger-check-buffer-name "*Ledger Check*")
(defvar ledger-original-window-cfg nil)
(defvar ledger-check-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [return] 'ledger-report-visit-source)
(define-key map [?q] 'ledger-check-quit)
map)
"Keymap for `ledger-check-mode'.")
(easy-menu-define ledger-check-mode-menu ledger-check-mode-map
"Ledger check menu"
'("Check"
;; ["Re-run Check" ledger-check-redo]
"---"
["Visit Source" ledger-report-visit-source]
"---"
["Quit" ledger-check-quit]
))
(define-derived-mode ledger-check-mode text-mode "Ledger-Check"
"A mode for viewing ledger errors and warnings.")
(defun ledger-do-check ()
"Run a check command ."
(goto-char (point-min))
(let ((data-pos (point))
(have-warnings nil))
(shell-command
;; ledger balance command will just return empty if you give it
;; an account name that doesn't exist. I will assume that no
;; one will ever have an account named "e342asd2131". If
;; someones does, this will probably still work for them.
;; I should only highlight error and warning lines.
"ledger bal e342asd2131 --strict --explicit "
t nil)
(goto-char data-pos)
;; format check report to make it navigate the file
(while (re-search-forward "^.*: \"\\(.*\\)\", line \\([0-9]+\\)" nil t)
(let ((file (match-string 1))
(line (string-to-number (match-string 2))))
(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 'font-lock-face 'ledger-font-report-clickable-face))
(setq have-warnings 'true)
(end-of-line))))
(if (not have-warnings)
(insert "No errors or warnings reported."))))
(defun ledger-check-goto ()
"Goto the ledger check buffer."
(interactive)
(let ((rbuf (get-buffer ledger-check-buffer-name)))
(if (not rbuf)
(error "There is no ledger check buffer"))
(pop-to-buffer rbuf)
(shrink-window-if-larger-than-buffer)))
(defun ledger-check-quit ()
"Quit the ledger check buffer."
(interactive)
(ledger-check-goto)
(set-window-configuration ledger-original-window-cfg)
(kill-buffer (get-buffer ledger-check-buffer-name)))
(defun ledger-check-buffer ()
"Check the current buffer for errors.
Runs ledger with --explicit and --strict report errors and assist
with fixing them.
The output buffer will be in `ledger-check-mode', which defines
commands for navigating the buffer to the errors found, etc."
(interactive
(progn
(when (and (buffer-modified-p)
(y-or-n-p "Buffer modified, save it? "))
(save-buffer))))
(let ((_buf (find-file-noselect (ledger-master-file)))
(cbuf (get-buffer ledger-check-buffer-name))
(wcfg (current-window-configuration)))
(if cbuf
(kill-buffer cbuf))
(with-current-buffer
(pop-to-buffer (get-buffer-create ledger-check-buffer-name))
(ledger-check-mode)
(set (make-local-variable 'ledger-original-window-cfg) wcfg)
(ledger-do-check)
(shrink-window-if-larger-than-buffer)
(set-buffer-modified-p nil)
(setq buffer-read-only t)
(message "q to quit; r to redo; k to kill"))))
(provide 'ledger-check)
;;; ledger-check.el ends here

161
lisp/ledger-mode/ledger-commodities.el Normal file
View File

@@ -0,0 +1,161 @@
;;; ledger-commodities.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; Helper functions to deal with commoditized numbers. A commoditized
;; number will be a list of value and string where the string contains
;; the commodity
;;; Code:
(require 'ledger-regex)
;; These keep the byte-compiler from warning about them, but have no other
;; effect:
(defvar ledger-environment-alist)
(declare-function ledger-exec-ledger "ledger-exec" (input-buffer &optional output-buffer &rest args))
(defcustom ledger-reconcile-default-commodity "$"
"The default commodity for use in target calculations in ledger reconcile."
:type 'string
:group 'ledger-reconcile)
(defun ledger-read-commodity-with-prompt (prompt)
"Read commodity name after PROMPT.
Default value is `ledger-reconcile-default-commodity'."
(let* ((buffer (current-buffer))
(commodities (with-temp-buffer
(ledger-exec-ledger buffer (current-buffer) "commodities")
(split-string (buffer-string) "\n" t))))
(completing-read prompt commodities nil t nil nil ledger-reconcile-default-commodity)))
(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
(t (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
(mapcar #'(lambda (st)
(ledger-split-commodity-string st))
(split-string str "[\n\r]")))
(defun ledger-subtract-commodity (c1 c2)
"Subtract C2 from C1, ensuring their commodities match."
(if (string= (cadr c1) (cadr c2))
(list (-(car c1) (car c2)) (cadr c1))
(error "Can't subtract different commodities %S from %S" c2 c1)))
(defun ledger-add-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)))
(defun ledger-strip (str char)
"Return STR with CHAR removed."
(replace-regexp-in-string char "" str))
(defun ledger-string-to-number (str &optional decimal-comma)
"Parse STR as a number and return that number.
Improves builtin `string-to-number' by handling
internationalization, and return nil if number can't be parsed.
See `ledger-environment-alist' for DECIMAL-COMMA."
(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)
"See `number-to-string' for N.
DECIMAL-COMMA is as documented in `ledger-environment-alist'."
(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)
(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)
(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))))))
(provide 'ledger-commodities)
;;; ledger-commodities.el ends here

362
lisp/ledger-mode/ledger-complete.el Normal file
View File

@@ -0,0 +1,362 @@
;;; ledger-complete.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; Functions providing payee and account auto complete.
(require 'cl-lib)
(eval-when-compile
(require 'subr-x))
;; In-place completion support
;;; Code:
(require 'ledger-context)
(require 'ledger-xact)
(require 'ledger-schedule)
(defcustom ledger-accounts-file nil
"The path to an optional file in which all accounts are used or declared.
This file will then be used as a source for account name completions."
:type 'file
:group 'ledger)
(defcustom ledger-accounts-exclude-function nil
"Function to exclude accounts from completion.
Should be a predicate function that accepts one argument, an
element of `ledger-accounts-list-in-buffer'."
:type 'function
:group 'ledger
:package-version '(ledger-mode . "2019-08-14"))
(defcustom ledger-complete-in-steps nil
"When non-nil, `ledger-complete-at-point' completes account names in steps.
If nil, full account names are offered for completion."
:type 'boolean
:group 'ledger
:package-version '(ledger-mode . "4.0.0"))
(defun ledger-parse-arguments ()
"Parse whitespace separated arguments in the current region."
;; FIXME: We don't use pcomplete anymore.
;; This is more complex than it appears
;; to need, so that it can work with pcomplete. See
;; pcomplete-parse-arguments-function for details
(let* ((begin (save-match-data
(if (looking-back (concat "^\\(" ledger-iso-date-regexp "=\\|\\)"
ledger-incomplete-date-regexp) nil)
(match-end 1)
(save-excursion
(ledger-thing-at-point) ;; leave point at beginning of thing under point
(point)))))
(end (point))
begins args)
;; to support end of line metadata
(save-excursion
(when (search-backward ";"
(line-beginning-position) t)
(setq begin (match-beginning 0))))
(save-excursion
(goto-char begin)
(when (< (point) end)
(skip-chars-forward " \t\n")
(setq begins (cons (point) begins))
(setq args (cons (buffer-substring-no-properties
(car begins) end)
args)))
(cons (reverse args) (reverse begins)))))
(defun ledger-payees-in-buffer ()
"Scan buffer and return list of all payees."
(let ((origin (point))
payees-list)
(save-excursion
(goto-char (point-min))
(while (re-search-forward
ledger-payee-any-status-regex nil t) ;; matches first line
(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
(sort (delete-dups payees-list) #'string-lessp)))
(defun ledger-accounts-in-buffer ()
"Return an alist of accounts in the current buffer.
The `car' of each element is the account name and the `cdr' is an
alist where the key is a subdirective such as \"assert\" and the
value (if any) is the associated data. In other words, if you've
declared an account like so:
account Assets:Checking
assert commodity == \"$\"
default
Then one of the elements this function returns will be
\(\"Assets:Checking\"
(\"default\")
(\"assert\" . \"commodity == \"$\"\"))"
(save-excursion
(goto-char (point-min))
(let (account-list
(seen (make-hash-table :test #'equal :size 1)))
;; First, consider accounts declared with "account" directives, which may or
;; may not have associated data. The data is on the following lines up to a
;; line not starting with whitespace.
(while (re-search-forward ledger-account-directive-regex nil t)
(let ((account (match-string-no-properties 1))
(lines (buffer-substring-no-properties
(point)
(progn (ledger-navigate-next-xact-or-directive)
(point))))
data)
(dolist (d (split-string lines "\n"))
(setq d (string-trim d))
(unless (string= d "")
(if (string-match " " d)
(push (cons (substring d 0 (match-beginning 0))
(substring d (match-end 0) nil))
data)
(push (cons d nil) data))))
(push (cons account data) account-list)
(puthash account t seen)))
;; Next, gather all accounts declared in postings
(unless
;; FIXME: People who have set `ledger-flymake-be-pedantic' to non-nil
;; probably don't want accounts from postings, just those declared
;; with directives. But the name is a little misleading. Should we
;; make a ledger-mode-be-pedantic and use that instead?
(bound-and-true-p ledger-flymake-be-pedantic)
(goto-char (point-min))
(while (re-search-forward ledger-account-name-or-directive-regex nil t)
(let ((account (match-string-no-properties 1)))
(unless (gethash account seen)
(puthash account t seen)
(push (cons account nil) account-list)))))
(sort account-list (lambda (a b) (string-lessp (car a) (car b)))))))
(defun ledger-accounts-list-in-buffer ()
"Return a list of all known account names in the current buffer as strings.
Considers both accounts listed in postings and those declared with \"account\" directives."
(let ((accounts (ledger-accounts-in-buffer)))
(when ledger-accounts-exclude-function
(setq accounts (cl-remove-if ledger-accounts-exclude-function accounts)))
(mapcar #'car accounts)))
(defun ledger-accounts-list ()
"Return a list of all known account names as strings.
Looks in `ledger-accounts-file' if set, otherwise the current buffer."
(if ledger-accounts-file
(let ((f ledger-accounts-file))
(with-temp-buffer
(insert-file-contents f)
(ledger-accounts-list-in-buffer)))
(ledger-accounts-list-in-buffer)))
(defun ledger-find-accounts-in-buffer ()
(let ((account-tree (list t))
(account-elements nil)
(prefix ""))
(save-excursion
(goto-char (point-min))
(dolist (account
(cl-remove-if-not (lambda (c) (string-prefix-p prefix c))
(ledger-accounts-list)))
(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-tree ()
"Return a tree of all accounts in the buffer."
(let* ((current (caar (ledger-parse-arguments)))
(elements (and current (split-string current ":")))
(root (ledger-find-accounts-in-buffer))
(prefix nil))
(while (cdr elements)
(let ((xact (assoc (car elements) root)))
(if xact
(setq prefix (concat prefix (and prefix ":")
(car elements))
root (cdr xact))
(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))))
(cdr root))
'string-lessp))))
(defun ledger-complete-date (month-string day-string)
"Complete a date."
(let*
((now (current-time))
(decoded (decode-time now))
(this-month (nth 4 decoded))
(this-year (nth 5 decoded))
(last-month (if (> this-month 1) (1- this-month) 12))
(last-year (1- this-year))
(last-month-year (if (> this-month 1) this-year last-year))
(month (and month-string
(string-to-number month-string)))
(day (string-to-number day-string))
(dates (list (encode-time 0 0 0 day (or month this-month) this-year)
(if month
(encode-time 0 0 0 day month last-year)
(encode-time 0 0 0 day last-month last-month-year)))))
(lambda (_string _predicate _all)
(concat (ledger-format-date
(cl-find-if (lambda (date) (not (time-less-p now date))) dates))
(and (= (point) (line-end-position)) " ")))))
(defun ledger-complete-effective-date
(tx-year-string tx-month-string tx-day-string
month-string day-string)
"Complete an effective date."
(let*
((tx-year (string-to-number tx-year-string))
(tx-month (string-to-number tx-month-string))
(tx-day (string-to-number tx-day-string))
(tx-date (encode-time 0 0 0 tx-day tx-month tx-year))
(next-month (if (< tx-month 12) (1+ tx-month) 1))
(next-year (1+ tx-year))
(next-month-year (if (< tx-month 12) tx-year next-year))
(month (and month-string
(string-to-number month-string)))
(day (string-to-number day-string))
(dates (list (encode-time 0 0 0 day (or month tx-month) tx-year)
(if month
(encode-time 0 0 0 day month next-year)
(encode-time 0 0 0 day next-month next-month-year)))))
(lambda (_string _predicate _all)
(concat (ledger-format-date
(cl-find-if (lambda (date) (not (time-less-p date tx-date))) dates))
(and (= (point) (line-end-position)) " ")))))
(defun ledger-complete-at-point ()
"Do appropriate completion for the thing at point."
(let ((end (point))
start collection
realign-after
delete-suffix)
(cond (;; Date
(looking-back (concat "^" ledger-incomplete-date-regexp) (line-beginning-position))
(setq collection (ledger-complete-date (match-string 1) (match-string 2))
start (match-beginning 0)
delete-suffix (save-match-data
(when (looking-at (rx (one-or-more (or digit (any ?/ ?-)))))
(length (match-string 0))))))
(;; Effective dates
(looking-back (concat "^" ledger-iso-date-regexp "=" ledger-incomplete-date-regexp)
(line-beginning-position))
(setq start (line-beginning-position))
(setq collection (ledger-complete-effective-date
(match-string 2) (match-string 3) (match-string 4)
(match-string 5) (match-string 6))))
(;; Payees
(eq (save-excursion (ledger-thing-at-point)) 'transaction)
(setq start (save-excursion (backward-word) (point)))
(setq collection #'ledger-payees-in-buffer))
(;; Accounts
(looking-back (rx-to-string `(seq bol (one-or-more space)
(optional (any ?\( ?\[ )) ;; for virtual accounts
(group (zero-or-more (not space)))))
(line-beginning-position))
(setq start (match-beginning 1)
delete-suffix (save-excursion
(when (search-forward-regexp (rx (or eol (repeat 2 space))) (line-end-position) t)
(- (match-beginning 0) end)))
realign-after t
collection (if ledger-complete-in-steps
#'ledger-accounts-tree
#'ledger-accounts-list))))
(when collection
(let ((prefix (buffer-substring-no-properties start end)))
(list start end
(if (functionp collection)
(completion-table-with-cache
(lambda (_)
(cl-remove-if (apply-partially 'string= prefix) (funcall collection))))
collection)
:exit-function (lambda (&rest _)
(when delete-suffix
(delete-char delete-suffix))
(when (and realign-after ledger-post-auto-align)
(ledger-post-align-postings (line-beginning-position) (line-end-position))))
'ignore)))))
(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.
Interactively, if point is after a payee, complete the
transaction with the details from the last transaction to that
payee."
(interactive)
(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
(when (re-search-backward
(concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*"
(regexp-quote name) ".*\\)" ) nil t)
(setq rest-of-name (match-string 3))
;; Start copying the postings
(forward-line)
(setq xacts (buffer-substring-no-properties (point) (ledger-navigate-end-of-xact))))))
;; Insert rest-of-name and the postings
(save-excursion
(insert rest-of-name ?\n)
(insert xacts)
(unless (looking-at-p "\n\n")
(insert "\n")))
(forward-line)
(goto-char (line-end-position))
(when (re-search-backward "\\(\t\\| [ \t]\\)" nil t)
(goto-char (match-end 0)))))
(provide 'ledger-complete)
;;; ledger-complete.el ends here

210
lisp/ledger-mode/ledger-context.el Normal file
View File

@@ -0,0 +1,210 @@
;;; ledger-context.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; Provide facilities for reflection in ledger buffers
;;; Code:
(require 'ledger-regex)
;; 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 ledger-amount-regexp)
(defconst ledger-commoditized-amount-string ledger-commoditized-amount-regexp)
(defconst ledger-balance-assertion-string ledger-balance-assertion-regexp)
(defconst ledger-comment-string "[ \t]*;[ \t]*\\(.*?\\)")
(defconst ledger-nil-string "\\([ \t]+\\)")
(defconst ledger-date-string "^\\([0-9]\\{4\\}[/-][01]?[0-9][/-][0123]?[0-9]\\)\\(?:=[0-9]\\{4\\}[/-][01]?[0-9][/-][0123]?[0-9]\\)?")
(defconst ledger-code-string "\\((.*)\\)?")
(defconst ledger-payee-string "\\(.*[^[:space:]]\\)")
(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."
`(list (ledger-line-regex (quote ,elements)) (quote ,elements)))
(defconst ledger-line-config
(list (list 'xact (list (ledger-single-line-config date nil status nil code nil payee comment)
(ledger-single-line-config date nil status nil code nil payee)
(ledger-single-line-config date nil status nil payee comment)
(ledger-single-line-config date nil status nil payee)
(ledger-single-line-config date nil code nil payee comment)
(ledger-single-line-config date nil code nil payee)
(ledger-single-line-config date nil payee comment)
(ledger-single-line-config date nil payee)))
(list 'acct-transaction (list (ledger-single-line-config indent comment)
(ledger-single-line-config indent status nil account separator commoditized-amount nil balance-assertion)
(ledger-single-line-config indent status nil account separator commoditized-amount comment)
(ledger-single-line-config indent status nil account separator commoditized-amount)
(ledger-single-line-config indent status nil account separator amount)
(ledger-single-line-config indent status nil account comment)
(ledger-single-line-config indent status nil account)
(ledger-single-line-config indent account separator commoditized-amount comment)
(ledger-single-line-config indent account separator commoditized-amount)
(ledger-single-line-config indent account separator amount)
(ledger-single-line-config indent account comment)
(ledger-single-line-config indent account)))))
(defun ledger-extract-context-info (line-type pos)
"Get context info for current line with LINE-TYPE.
Assumes point is at beginning of line, and the POS argument specifies
where the \"users\" point was."
(let ((linfo (assoc line-type ledger-line-config))
found field fields)
(dolist (re-info (nth 1 linfo))
(let ((re (nth 0 re-info))
(names (nth 1 re-info)))
(unless found
(when (looking-at re)
(setq found t)
(dotimes (i (length names))
(when (nth i names)
(setq fields (append fields
(list
(list (nth i names)
(match-string-no-properties (1+ i))
(match-beginning (1+ i))))))))
(dolist (f fields)
(and (nth 1 f)
(>= pos (nth 2 f))
(setq field (nth 0 f))))))))
(list line-type field fields)))
(defun ledger-thing-at-point ()
"Describe thing at points. Return 'transaction, 'posting, or nil.
Leave point at the beginning of the thing under point"
(let ((here (point)))
(goto-char (line-beginning-position))
(cond ((looking-at "^\\(?:[~=][ \t]\\|[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.+?)\\)?\\s-+\\)")
(goto-char (match-end 0))
'transaction)
((looking-at "^\\s-+\\([*!]\\s-+\\)?[[(]?\\([^\\s-]\\)")
(goto-char (match-beginning 2))
'posting)
((looking-at "^\\(sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat\\)\\s-+")
(goto-char (match-end 0))
'day)
(t
(ignore (goto-char here))))))
(defun ledger-context-at-point ()
"Return a list describing the context around point.
The contents of the list are the line type, the name of the field
containing point, and for selected line types, the content of
the fields in the line in a association list."
(let ((pos (point)))
(save-excursion
(beginning-of-line)
(let ((first-char (char-after)))
(cond ((equal (point) (line-end-position))
'(empty-line nil nil))
((memq first-char '(?\ ?\t))
(ledger-extract-context-info 'acct-transaction pos))
((memq first-char '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
(ledger-extract-context-info 'xact pos))
((equal first-char ?\=)
'(automated-xact nil nil))
((equal first-char ?\~)
'(period-xact nil nil))
((equal first-char ?\!)
'(command-directive))
((equal first-char ?\;)
'(comment nil nil))
((equal first-char ?Y)
'(default-year nil nil))
((equal first-char ?P)
'(commodity-price nil nil))
((equal first-char ?N)
'(price-ignored-commodity nil nil))
((equal first-char ?D)
'(default-commodity nil nil))
((equal first-char ?C)
'(commodity-conversion nil nil))
((equal first-char ?i)
'(timeclock-i nil nil))
((equal first-char ?o)
'(timeclock-o nil nil))
((equal first-char ?b)
'(timeclock-b nil nil))
((equal first-char ?h)
'(timeclock-h nil nil))
(t
'(unknown nil nil)))))))
(defun ledger-context-other-line (offset)
"Return a list describing context of line OFFSET from existing position.
Offset can be positive or negative. If run out of buffer before reaching
specified line, returns nil."
(save-excursion
(let ((left (forward-line offset)))
(if (not (equal left 0))
nil
(ledger-context-at-point)))))
(defun ledger-context-line-type (context-info)
(nth 0 context-info))
(defun ledger-context-current-field (context-info)
(nth 1 context-info))
(defun ledger-context-field-info (context-info field-name)
(assoc field-name (nth 2 context-info)))
(defun ledger-context-field-present-p (context-info field-name)
(not (null (ledger-context-field-info context-info field-name))))
(defun ledger-context-field-value (context-info field-name)
(nth 1 (ledger-context-field-info context-info field-name)))
(defun ledger-context-field-position (context-info field-name)
(nth 2 (ledger-context-field-info context-info field-name)))
(defun ledger-context-field-end-position (context-info field-name)
(+ (ledger-context-field-position context-info field-name)
(length (ledger-context-field-value context-info field-name))))
(defun ledger-context-goto-field-start (context-info field-name)
(goto-char (ledger-context-field-position context-info field-name)))
(defun ledger-context-goto-field-end (context-info field-name)
(goto-char (ledger-context-field-end-position context-info field-name)))
(provide 'ledger-context)
;;; ledger-context.el ends here

125
lisp/ledger-mode/ledger-exec.el Normal file
View File

@@ -0,0 +1,125 @@
;;; ledger-exec.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; Code for executing ledger synchronously.
;;; Code:
(declare-function ledger-master-file "ledger-report" ())
(defconst ledger-version-needed "3.0.0"
"The version of ledger executable needed for interactive features.")
(defvar ledger-works nil
"Flag showing whether the ledger binary can support `ledger-mode' interactive features.")
(defgroup ledger-exec nil
"Interface to the Ledger command-line accounting program."
:group 'ledger)
(defcustom ledger-mode-should-check-version t
"Should Ledger-mode verify that the executable is working?"
:type 'boolean
:group 'ledger-exec)
(defcustom ledger-binary-path "ledger"
"Path to the ledger executable."
:type 'file
:risky t
:group 'ledger-exec)
(defun ledger-exec-handle-error (ledger-errfile)
"Deal with ledger errors contained in LEDGER-ERRFILE."
(with-current-buffer (get-buffer-create "*Ledger Error*")
(let ((buffer-read-only nil))
(delete-region (point-min) (point-max))
(insert-file-contents ledger-errfile))
(view-mode)
(setq buffer-read-only t)
(current-buffer)))
(defun ledger-exec-success-p (exit-code ledger-output-buffer)
"Return t if EXIT-CODE is non-zero and output in LEDGER-OUTPUT-BUFFER is successful."
(with-current-buffer ledger-output-buffer
(goto-char (point-min))
(if (or (not (zerop exit-code))
(and (> (buffer-size) 1) (looking-at (regexp-quote "While"))))
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.
Optionally capture output in OUTPUT-BUFFER, and pass ARGS on the
command line. Returns OUTPUT-BUFFER if ledger succeeded,
otherwise the error output is displayed and an error is raised."
(unless (and ledger-binary-path
(or (and (file-exists-p ledger-binary-path)
(file-executable-p ledger-binary-path))
(executable-find ledger-binary-path)))
(error "`ledger-binary-path' (value: %s) is not executable" ledger-binary-path))
(let ((buf (or input-buffer (find-file-noselect (ledger-master-file))))
(outbuf (or output-buffer
(generate-new-buffer " *ledger-tmp*")))
(errfile (make-temp-file "ledger-errors")))
(unwind-protect
(with-current-buffer buf
(let ((exit-code
(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 (list outbuf errfile) nil "-f" "-")
args)))))
(if (ledger-exec-success-p exit-code outbuf)
outbuf
(display-buffer (ledger-exec-handle-error errfile))
(error "Ledger execution failed"))))
(delete-file errfile))))
(defun ledger-version-greater-p (needed)
"Verify the ledger binary is usable for `ledger-mode' (version greater than NEEDED)."
(let ((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
(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"))))
(provide 'ledger-exec)
;;; ledger-exec.el ends here

142
lisp/ledger-mode/ledger-flymake.el Normal file
View File

@@ -0,0 +1,142 @@
;;; ledger-flymake.el --- A ledger Flymake backend -*- lexical-binding: t; -*-
;; Copyright (C) 2018 J. Alexander Branham (alex DOT branham 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 3, 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:
;; Flymake is the built-in Emacs package to support on-the-fly syntax checking.
;; This file adds support for flymake to `ledger-mode'. Enable it by calling
;; `flymake-mode' from a file-visiting ledger buffer.
;;; Code:
(require 'cl-lib)
(require 'flymake)
(require 'ledger-exec) ; for `ledger-binary-path'
;; To silence byte compiler warnings in Emacs 25 and older:
(declare-function flymake-diag-region "flymake" (buffer line &optional col))
(declare-function flymake-make-diagnostic "flymake" (buffer beg end type text &optional data overlay-properties))
(defvar-local ledger--flymake-proc nil)
(defcustom ledger-flymake-be-pedantic nil
"If non-nil, pass the --pedantic flag for ledger to the flymake backend.
If --pedantic is in your ledgerrc file, then --pedantic gets
passed regardless of the value."
:type 'boolean
:package-version '(ledger-mode . "4.0.0")
:group 'ledger)
(defcustom ledger-flymake-be-explicit nil
"If non-nil, pass the --explicit flag for ledger to the flymake backend.
If --explicit is in your ledgerrc file, then --explicit gets
passed regardless of the value."
:type 'boolean
:package-version '(ledger-mode . "4.0.0")
:group 'ledger)
;; Based on the example from Flymake's info:
(defun ledger-flymake (report-fn &rest _args)
"A Flymake backend for `ledger-mode'.
Flymake calls this with REPORT-FN as needed."
(unless (executable-find ledger-binary-path)
(error "Cannot find ledger"))
;; If a live process launched in an earlier check was found, that
;; process is killed. When that process's sentinel eventually runs,
;; it will notice its obsoletion, since it have since reset
;; `ledger-flymake-proc' to a different value
(when (process-live-p ledger--flymake-proc)
(kill-process ledger--flymake-proc))
;; Save the current buffer, the narrowing restriction, remove any
;; narrowing restriction.
(let ((source (current-buffer))
(file (buffer-file-name)))
(save-restriction
(widen)
;; Reset the `ledger--flymake-proc' process to a new process
;; calling the ledger tool.
(setq
ledger--flymake-proc
(make-process
:name "ledger-flymake" :noquery t :connection-type 'pipe
:buffer (generate-new-buffer " *ledger-flymake*")
:command (cl-remove
nil
`(,ledger-binary-path "-f" ,file
,(when ledger-flymake-be-pedantic "--pedantic")
,(when ledger-flymake-be-explicit "--explicit")
"balance"))
:sentinel
(lambda (proc _event)
;; Check that the process has indeed exited, as it might
;; be simply suspended.
(when (eq 'exit (process-status proc))
(unwind-protect
;; Only proceed if `proc' is the same as
;; `ledger--flymake-proc', which indicates that
;; `proc' is not an obsolete process.
(if (with-current-buffer source (eq proc ledger--flymake-proc))
(with-current-buffer (process-buffer proc)
(goto-char (point-min))
;; Parse the output buffer for diagnostic's
;; messages and locations, collect them in a list
;; of objects, and call `report-fn'.
(cl-loop
while (search-forward-regexp
;; This regex needs to match the whole error. We
;; also need a capture group for the error message
;; (that's group 1 here) and the line number
;; (group 2).
(rx line-start "While parsing file \"" (one-or-more (not whitespace)) " line " (group-n 2 (one-or-more num)) ":\n"
(zero-or-more line-start "While " (one-or-more not-newline) "\n" )
(minimal-match (zero-or-more line-start (zero-or-more not-newline) "\n"))
(group-n 1 "Error: " (one-or-more not-newline) "\n"))
nil t)
for msg = (match-string 1)
for (beg . end) = (flymake-diag-region
source
(string-to-number (match-string 2)))
for type = :error
collect (flymake-make-diagnostic source
beg
end
type
msg)
into diags
finally (funcall report-fn diags)))
(flymake-log :warning "Canceling obsolete check %s"
proc))
;; Cleanup the temporary buffer used to hold the
;; check's output.
(kill-buffer (process-buffer proc))))))))))
;;;###autoload
(defun ledger-flymake-enable ()
"Enable `flymake-mode' in `ledger-mode' buffers."
(unless (> emacs-major-version 25)
(error "Ledger-flymake requires Emacs version 26 or higher"))
;; Add `ledger-flymake' to `flymake-diagnostic-functions' so that flymake can
;; work in ledger-mode:
(add-hook 'flymake-diagnostic-functions 'ledger-flymake nil t)
(flymake-mode))
(provide 'ledger-flymake)
;;; ledger-flymake.el ends here

58
lisp/ledger-mode/ledger-fontify.el Normal file
View File

@@ -0,0 +1,58 @@
;;; ledger-fontify.el --- Provide custom fontification for ledger-mode -*- lexical-binding: t; -*-
;; 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)
;; These are dynamically bound, see `font-lock-extend-region-functions'.
(defvar font-lock-beg)
(defvar font-lock-end)
(defcustom ledger-fontify-xact-state-overrides nil
"If t the highlight entire xact with state."
:type 'boolean
:group 'ledger)
(defun ledger-fontify-extend-region ()
"Extend fontification region to include whole transactions or directives."
(save-match-data
(let* ((new-beg (min font-lock-beg (car (ledger-navigate-find-element-extents font-lock-beg))))
(new-end (max font-lock-end (cadr (ledger-navigate-find-element-extents font-lock-end))))
(changed (or (/= new-beg font-lock-beg)
(/= new-end font-lock-end))))
(setq font-lock-beg new-beg)
(setq font-lock-end new-end)
changed)))
(provide 'ledger-fontify)
;;; ledger-fontify.el ends here

684
lisp/ledger-mode/ledger-fonts.el Normal file
View File

@@ -0,0 +1,684 @@
;;; ledger-fonts.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; All of the faces for ledger mode are defined here.
;;; Code:
(require 'ledger-navigate)
(require 'ledger-regex)
(require 'ledger-state)
(require 'ledger-fontify)
(defgroup ledger-faces nil "Ledger mode highlighting" :group 'ledger)
(defface ledger-font-auto-xact-face
`((t :inherit font-lock-negation-char-face))
"Default face for automatic transactions"
:group 'ledger-faces)
(defface ledger-font-periodic-xact-face
`((t :inherit font-lock-constant-face))
"Default face for automatic transactions"
:group 'ledger-faces)
(defface ledger-font-xact-cleared-face
`((t :inherit ledger-font-payee-cleared-face))
"Default face for cleared transaction"
:group 'ledger-faces)
(defface ledger-font-xact-pending-face
`((t :inherit ledger-font-pending-face))
"Default face for pending transaction"
:group 'ledger-faces)
(defface ledger-font-payee-uncleared-face
`((t :inherit error))
"Default face for Ledger"
:group 'ledger-faces)
(defface ledger-font-payee-cleared-face
`((t :inherit shadow))
"Default face for cleared (*) payees"
:group 'ledger-faces)
(defface ledger-font-payee-pending-face
`((t :inherit ledger-font-pending-face))
"Default face for pending (!) payees"
:group 'ledger-faces)
(defface ledger-font-xact-highlight-face
`((t
,@(and (>= emacs-major-version 27) '(:extend t))
:inherit ledger-occur-xact-face))
"Default face for transaction under point"
:group 'ledger-faces)
(defface ledger-font-pending-face
`((t :inherit warning))
"Default face for pending (!) transactions"
:group 'ledger-faces)
(defface ledger-font-other-face
`((t :inherit font-lock-type-face))
"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-account-name-face
`((t :inherit font-lock-variable-name-face))
"Face for account names in account and alias directives"
:group 'ledger-faces)
(defface ledger-font-note-directive-face
`((t :inherit ledger-font-directive-face))
"Face for note subdirectives"
:group 'ledger-faces)
(defface ledger-font-note-text-face
`((t :inherit font-lock-doc-face))
"Face for note subdirective text"
:group 'ledger-faces)
(defface ledger-font-default-directive-face
`((t :inherit ledger-font-directive-face))
"Face for default subdirectives"
: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-price-date-face
`((t :inherit default))
"Face for date and time in price directive"
:group 'ledger-faces)
(defface ledger-font-price-symbol-face
`((t :inherit font-lock-constant-face))
"Face for symbol in price directive"
:group 'ledger-faces)
(defface ledger-font-price-face
`((t :inherit default))
"Face for price in price directive"
: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-apply-account-face
`((t :inherit default))
"Face for argument of apply account directive"
:group 'ledger-faces)
(defface ledger-font-apply-tag-face
`((t :inherit default))
"Face for argument of apply tag directive"
: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-alias-definition-face
`((t :inherit default))
"Face for aliased account in alias directives"
: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-condition-face
`((t :inherit default))
"Default face for check and assert conditions"
:group 'ledger-faces)
(defface ledger-font-assert-condition-face
`((t :inherit ledger-font-condition-face))
"Face for assert conditions"
: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-bucket-account-face
`((t :inherit default))
"Face for bucket directive argument"
:group 'ledger-faces)
(defface ledger-font-C-directive-face
`((t :inherit ledger-font-directive-face))
"Default face for C directive"
:group 'ledger-faces)
(defface ledger-font-C-amount-face
`((t :inherit default))
"Face for amounts in C directives"
: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-capture-account-face
`((t :inherit default))
"Face for account name in capture directives"
:group 'ledger-faces)
(defface ledger-font-capture-regex-face
`((t :inherit default))
"Face for match regex in capture directives"
: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-check-condition-face
`((t :inherit ledger-font-condition-face))
"Face for check conditions"
: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-commodity-name-face
`((t :inherit font-lock-constant-face))
"Face for commodity name in commodity directives"
:group 'ledger-faces)
(defface ledger-font-format-directive-face
`((t :inherit ledger-font-directive-face))
"Face for format subdirective"
:group 'ledger-faces)
(defface ledger-font-commodity-format-face
`((t :inherit default))
"Face for format subdirective argument"
:group 'ledger-faces)
(defface ledger-font-D-directive-face
`((t :inherit ledger-font-directive-face))
"Default face for D directive"
: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-define-name-face
`((t :inherit font-lock-variable-name-face))
"Face for variable name in define directive"
:group 'ledger-faces)
(defface ledger-font-define-body-face
`((t :inherit default))
"Face for body in define directive"
: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-expr-expression-face
`((t :inherit default))
"Face for expr and eval expressions"
: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-fixed-commodity-face
`((t :inherit font-lock-constant-face))
"Face for commodity name in fixed directive"
:group 'ledger-faces)
(defface ledger-font-fixed-price-face
`((t :inherit default))
"Face for price in fixed directive"
: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-include-filename-face
`((t :inherit font-lock-string-face))
"Face for file name in include directives"
:group 'ledger-faces)
(defface ledger-font-N-directive-face
`((t :inherit ledger-font-directive-face))
"Default face for N directive"
:group 'ledger-faces)
(defface ledger-font-N-symbol-face
`((t :inherit default))
"Face for symbol in N directives")
(defface ledger-font-payee-directive-face
`((t :inherit ledger-font-directive-face))
"Default face for other transactions"
:group 'ledger-faces)
(defface ledger-font-payee-name-face
`((t :inherit font-lock-function-name-face))
"Face for payee name in payee directive"
:group 'ledger-faces)
(defface ledger-font-payee-regex-face
`((t :inherit font-lock-string-face))
"Face for payee subdirective regex in account directive"
:group 'ledger-faces)
(defface ledger-font-uuid-directive-face
`((t :inherit ledger-font-directive-face))
"Face for uuid subdirectives"
:group 'ledger-faces)
(defface ledger-font-uuid-face
`((t :inherit default))
"Face for uuid in uuid subdirectives"
: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-tag-name-face
`((t :inherit font-lock-type-face))
"Face for tag name in tag directive"
:group 'ledger-faces)
(defface ledger-font-timeclock-directive-face
`((t :inherit ledger-font-directive-face))
"Default face for timeclock I,i,O,o,b,h directives"
: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-year-face
`((t :inherit default))
"Font for year in year directives"
:group 'ledger-faces)
(defface ledger-font-posting-account-face
`((t :inherit ledger-font-default-face))
"Face for Ledger accounts"
:group 'ledger-faces)
(defface ledger-font-posting-account-cleared-face
`((t :inherit ledger-font-payee-cleared-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 :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 :inherit font-lock-constant-face ))
"Face for Ledger amounts"
:group 'ledger-faces)
(defface ledger-font-posting-date-face
`((t :inherit font-lock-keyword-face))
"Face for Ledger dates"
:group 'ledger-faces)
(defface ledger-occur-narrowed-face
`((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 :inherit highlight))
"Default face for Ledger occur mode shown transactions"
:group 'ledger-faces)
(defface ledger-font-comment-face
`((t :inherit font-lock-comment-face))
"Face for Ledger comments"
:group 'ledger-faces)
(defface ledger-font-reconciler-uncleared-face
`((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 :inherit ledger-font-payee-cleared-face))
"Default face for cleared (*) transactions in the reconcile window"
:group 'ledger-faces)
(defface ledger-font-reconciler-pending-face
`((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))
"Face applied to clickable entries in the report window"
:group 'ledger-faces)
(defface ledger-font-code-face
`((t :inherit default))
"Face for Ledger codes"
:group 'ledger-faces)
(defun ledger-font-face-by-state (num faces)
"Choose one of three faces depending on transaction state.
NUM specifies a match group containing the state.
FACES has the form (CLEARED PENDING OTHER).
Return CLEARED if that group specifies a cleared transaction,
PENDING if pending, and OTHER if none of the above."
(let ((state (save-match-data (ledger-state-from-string (match-string num)))))
(cond ((eq state 'cleared) (nth 0 faces))
((eq state 'pending) (nth 1 faces))
(t (nth 2 faces)))))
(defun ledger-font-face-by-timeclock-state (num faces)
"Choose one of two faces depending on a timeclock directive character.
NUM specifies a match group containing the character.
FACES has the form (CLEARED UNCLEARED).
Return CLEARED if the character specifies a cleared transaction,
UNCLEARED otherwise."
(if (member (match-string num) '("I" "O"))
(nth 0 faces)
(nth 1 faces)))
(defun ledger-font-subdirectives (subdirectives)
"Construct anchored highlighters for subdirectives.
Each element of SUBDIRECTIVES should have the form (MATCHER
SUBEXP-HIGHLIGHTERS…). The result will be a list of elements of
the form (MATCHER PRE-FORM POST-FORM SUBEXP-HIGHLIGHTERS) with
PRE-FORM and POST-FORM set to appropriate values.
See `font-lock-keywords' for the full description."
(mapcar (lambda (item)
`(,(car item)
(save-excursion
(save-match-data
(ledger-navigate-end-of-xact))
(point))
(goto-char (match-end 0))
,@(cdr item)))
subdirectives))
(defvar ledger-font-lock-keywords
`(("^[;#%|*].*$" . 'ledger-font-comment-face)
("^\\(account\\)\\(?:[[:blank:]]\\(.*\\)\\)?$"
(1 'ledger-font-account-directive-face)
(2 'ledger-font-account-name-face nil :lax)
,@(ledger-font-subdirectives
'(("^[ \t]+\\(;.*\\)" (1 'ledger-font-comment-face))
("^[ \t]+\\(note\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-note-directive-face)
(2 'ledger-font-note-text-face nil :lax))
("^[ \t]+\\(alias\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-alias-directive-face)
(2 'ledger-font-account-name-face nil :lax))
("^[ \t]+\\(payee\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-payee-directive-face)
(2 'ledger-font-payee-regex-face nil :lax))
("^[ \t]+\\(check\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-check-directive-face)
(2 'ledger-font-check-condition-face nil :lax))
("^[ \t]+\\(assert\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-assert-directive-face)
(2 'ledger-font-assert-condition-face nil :lax))
("^[ \t]+\\(eval\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-expr-directive-face)
(2 'ledger-font-expr-expression-face nil :lax))
("^[ \t]+\\(default\\)\\>.*"
(1 'ledger-font-default-directive-face)))))
("^\\(alias\\)\\(?:[[:blank:]]+\\([^=\n]*\\)\\(?:=\\(.*\\)\\)?\\)?$"
(1 'ledger-font-alias-directive-face)
(2 'ledger-font-account-name-face nil :lax)
(3 'ledger-font-alias-definition-face nil :lax))
(,(concat "^\\(apply\\)\\(?:[[:blank:]]+"
"\\(?:\\(account\\)\\(?:[[:blank:]]+\\(.*\\)\\)?"
"\\|\\(tag\\)\\(?:[[:blank:]]+\\(.*\\)\\)?\\)\\)?$")
(1 'ledger-font-apply-directive-face)
(2 'ledger-font-apply-directive-face nil :lax)
(3 'ledger-font-apply-account-face nil :lax)
(4 'ledger-font-apply-directive-face nil :lax)
(5 'ledger-font-apply-tag-face nil :lax))
("^\\(assert\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-assert-directive-face)
(2 'ledger-font-assert-condition-face nil :lax))
("^\\(bucket\\|A\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-bucket-directive-face)
(2 'ledger-font-bucket-account-face nil :lax))
(,(concat "^\\(C\\)"
"\\(?:[[:blank:]]+\\([^=\n]*?\\)[[:blank:]]*"
"\\(?:=[[:blank:]]*\\(.*\\)\\)?\\)?$")
(1 'ledger-font-C-directive-face)
(2 'ledger-font-C-amount-face nil :lax)
(3 'ledger-font-C-amount-face nil :lax))
(,(concat "^\\(capture\\)"
"\\(?:[[:blank:]]+\\(.*?\\)"
"\\(?:\\(?:\t\\|[ \t]\\{2,\\}\\)\\(.*\\)\\)?\\)?$")
(1 'ledger-font-capture-directive-face)
(2 'ledger-font-capture-account-face nil :lax)
(3 'ledger-font-capture-regex-face nil :lax))
("^\\(check\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-check-directive-face)
(2 'ledger-font-check-condition-face nil :lax))
(,(concat "^\\(?:comment\\|test\\)\\>"
"[^\0]*?\n"
"end[[:blank:]]+\\(?:comment\\|test\\)\\>.*\n")
. 'ledger-font-comment-face)
("^\\(commodity\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-commodity-directive-face)
(2 'ledger-font-commodity-name-face nil :lax)
,@(ledger-font-subdirectives
'(("^[ \t]+\\(;.*\\)" (1 'ledger-font-comment-face))
("^[ \t]+\\(note\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-note-directive-face)
(2 'ledger-font-note-text-face nil :lax))
("^[ \t]+\\(format\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-format-directive-face)
(2 'ledger-font-commodity-format-face nil :lax))
("^[ \t]+\\(nomarket\\)\\>.*"
(1 'ledger-font-N-directive-face))
("^[ \t]+\\(default\\)\\>.*"
(1 'ledger-font-default-directive-face)))))
("^\\(D\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-D-directive-face)
(2 'ledger-font-commodity-format-face nil :lax))
(,(concat "^\\(define\\|def\\)"
"\\(?:[[:blank:]]+\\([^=\n]*?\\)[[:blank:]]*"
"\\(?:=[[:blank:]]*\\(.*\\)\\)?\\)?$")
(1 'ledger-font-define-directive-face)
(2 'ledger-font-define-name-face nil :lax)
(3 'ledger-font-define-body-face nil :lax))
(,(concat "^\\(end\\)"
"\\(?:[[:blank:]]+\\(apply\\)"
"\\(?:[[:blank:]]+\\(account\\|tag\\)\\>.*\\)?\\)?$")
(1 'ledger-font-end-directive-face)
(2 'ledger-font-end-directive-face nil :lax)
(3 'ledger-font-end-directive-face nil :lax))
("^\\(endfixed\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-end-directive-face)
(2 'ledger-font-fixed-commodity-face nil :lax))
("^\\(expr\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-expr-directive-face)
(2 'ledger-font-expr-expression-face nil :lax))
("^\\(fixed\\)\\(?:[[:blank:]]+\\([^[:blank:]\n]+\\)\\(?:[[:blank:]]+\\(.*\\)\\)?\\)?$"
(1 'ledger-font-fixed-directive-face)
(2 'ledger-font-fixed-commodity-face nil :lax)
(3 'ledger-font-fixed-price-face nil :lax))
("^\\(include\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-include-directive-face)
(2 'ledger-font-include-filename-face nil :lax))
("^\\(N\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-N-directive-face)
(2 'ledger-font-N-symbol-face nil :lax))
("^\\(payee\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-payee-directive-face)
(2 'ledger-font-payee-name-face nil :lax)
,@(ledger-font-subdirectives
'(("^[ \t]+\\(;.*\\)" (1 'ledger-font-comment-face))
("^[ \t]+\\(alias\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-alias-directive-face)
(2 'ledger-font-payee-regex-face nil :lax))
("^[ \t]+\\(uuid\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-uuid-directive-face)
(2 'ledger-font-uuid-face nil :lax)))))
(,(concat "^\\(P\\)"
"\\(?:[[:blank:]]+\\([^[:blank:]\n]+"
"\\(?:[[:blank:]]+[[:digit:]][^[:blank:]\n]*\\)?\\)"
"\\(?:[[:blank:]]+\\([^[:blank:]\n]+\\)"
"\\(?:[[:blank:]]+\\(.*\\)\\)?\\)?\\)?$")
(1 'ledger-font-price-directive-face)
(2 'ledger-font-price-date-face nil :lax)
(3 'ledger-font-price-symbol-face nil :lax)
(4 'ledger-font-price-face nil :lax))
("^\\(tag\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-tag-directive-face)
(2 'ledger-font-tag-name-face nil :lax)
,@(ledger-font-subdirectives
'(("^[ \t]+\\(;.*\\)" (1 'ledger-font-comment-face))
("^[ \t]+\\(check\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-check-directive-face)
(2 'ledger-font-check-condition-face nil :lax))
("^[ \t]+\\(assert\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-assert-directive-face)
(2 'ledger-font-assert-condition-face nil :lax)))))
(,(concat "^\\([IiOo]\\)"
"\\(?:[[:blank:]]+\\([^[:blank:]\n]+"
"\\(?:[[:blank:]]+[^[:blank:]\n]+\\)?\\)"
"\\(?:[[:blank:]]+\\(.*?\\)"
"\\(?:\t\\|[ \t]\\{2,\\}\\(.*?\\)"
"\\(?:\t\\|[ \t]\\{2,\\}\\(;.*\\)\\)?\\)?\\)?\\)?$")
(1 'ledger-font-timeclock-directive-face)
(2 'ledger-font-posting-date-face nil :lax)
(3 (ledger-font-face-by-timeclock-state 1 '(ledger-font-posting-account-cleared-face
ledger-font-posting-account-face)) nil :lax)
(4 (ledger-font-face-by-timeclock-state 1 '(ledger-font-payee-cleared-face
ledger-font-payee-uncleared-face)) nil :lax)
(5 'ledger-font-comment-face nil :lax))
("^\\([bh]\\)\\>.*$" (1 'ledger-font-timeclock-directive-face))
("^\\(year\\|Y\\)\\(?:[[:blank:]]+\\(.*\\)\\)?$"
(1 'ledger-font-year-directive-face)
(2 'ledger-font-year-face nil :lax))
(,(lambda (limit)
(when ledger-fontify-xact-state-overrides
(re-search-forward
(concat "^\\(?:\\([=~]\\)[ \t].*\\|" ; auto/periodic, subexpr 1
"[[:digit:]][^ \t\n]*" ; date
"[ \t]+\\([*!]\\)" ; mark, subexp 2
".*\\)" ; rest of header
"\\(?:\n[ \t]+.*\\)*" ; postings
)
limit t)))
(0 (cond ((equal "=" (match-string 1)) 'ledger-font-auto-xact-face)
((equal "~" (match-string 1)) 'ledger-font-periodic-xact-face)
(t (ledger-font-face-by-state 2 '(ledger-font-xact-cleared-face
ledger-font-xact-pending-face))))))
(,(concat "^\\(?:\\(\\([=~]\\).*\\)\\|" ; auto/periodic, subexp 1, 2
"\\([[:digit:]][^ \t\n]*\\)" ; date, subexp 3
ledger-xact-after-date-regex "\\)") ; mark 4, code 5, desc 6, comment 7
(1 (cond ((equal "=" (match-string 2)) 'ledger-font-auto-xact-face)
((equal "~" (match-string 2)) 'ledger-font-periodic-xact-face)
(t 'ledger-font-default-face))
nil :lax)
(3 'ledger-font-posting-date-face nil :lax)
(5 'ledger-font-code-face nil :lax)
(6 (ledger-font-face-by-state 4 '(ledger-font-payee-cleared-face
ledger-font-payee-pending-face
ledger-font-payee-uncleared-face))
nil :lax)
(7 'ledger-font-comment-face nil :lax)
,@(ledger-font-subdirectives
`(("^[ \t]+\\(;.*\\)"
(1 'ledger-font-comment-face))
(,ledger-posting-regex ; state and account 1, state 2, account 3, amount 4, comment 5
(1 (ledger-font-face-by-state 2 '(ledger-font-posting-account-cleared-face
ledger-font-posting-account-pending-face
ledger-font-posting-account-face))
nil :lax)
(4 (ledger-font-face-by-state 2 '(ledger-font-posting-amount-cleared-face
ledger-font-posting-amount-pending-face
ledger-font-posting-amount-face))
nil :lax)
(5 'ledger-font-comment-face nil :lax))))))
"Expressions to highlight in Ledger mode.")
(provide 'ledger-fonts)
;;; ledger-fonts.el ends here

98
lisp/ledger-mode/ledger-init.el Normal file
View File

@@ -0,0 +1,98 @@
;;; ledger-init.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 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."
:type 'file
:group 'ledger-exec)
(defvar ledger-environment-alist nil
"Variable to hold details about ledger-mode's environment.
Adding the dotted pair (\"decimal-comma\" . t) will tell ledger
to treat commas as decimal separator.")
(defcustom ledger-default-date-format "%Y/%m/%d"
"The date format that ledger uses throughout.
Set this to the value of `ledger-iso-date-format' if you prefer
ISO 8601 dates."
:type 'string
:package-version '(ledger-mode . "4.0.0")
:group 'ledger)
(defconst ledger-iso-date-format "%Y-%m-%d"
"The format for ISO 8601 dates.")
(defun ledger-format-date (&optional date)
"Format DATE according to the current preferred date format.
Returns the current date if DATE is nil or not supplied."
(format-time-string
(or (cdr (assoc "input-date-format" ledger-environment-alist))
ledger-default-date-format)
date))
(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))))))))
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
(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))
(let ((init-buffer (find-file-noselect ledger-init-file-name)))
(setq ledger-environment-alist
(ledger-init-parse-initialization init-buffer))
(kill-buffer init-buffer))))))
(provide 'ledger-init)
;;; ledger-init.el ends here

6
lisp/ledger-mode/ledger-mode-pkg.el Normal file
View File

@@ -0,0 +1,6 @@
(define-package "ledger-mode" "20200530.1710" "Helper code for use with the \"ledger\" command-line tool"
'((emacs "25.1"))
:commit "f8463744191b4feb9fea54190917663f7ba26102")
;; Local Variables:
;; no-byte-compile: t
;; End:

334
lisp/ledger-mode/ledger-mode.el Normal file
View File

@@ -0,0 +1,334 @@
;;; ledger-mode.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; Package-Requires: ((emacs "25.1"))
;; 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:
;; Most of the general ledger-mode code is here.
;;; Code:
(require 'ledger-regex)
(require 'org)
(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)
(require 'ledger-report)
(require 'ledger-sort)
(require 'ledger-state)
(require 'ledger-test)
(require 'ledger-texi)
(require 'ledger-xact)
(require 'ledger-schedule)
(require 'ledger-check)
(declare-function custom-group-members "cus-edit" (symbol groups-only))
;;; Code:
(defgroup ledger nil
"Interface to the Ledger command-line accounting program."
:group 'data)
(defconst ledger-version "3.0"
"The version of ledger.el currently loaded.")
(defconst ledger-mode-version "4.0.0")
(defun ledger-mode-dump-variable (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."
(require 'cus-edit)
(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)))))))
(defun ledger-mode-dump-configuration ()
"Dump all customizations."
(interactive)
(find-file "ledger-mode-dump")
(ledger-mode-dump-group 'ledger))
(defun ledger-read-account-with-prompt (prompt)
"Read an account from the minibuffer with PROMPT."
(let* ((context (ledger-context-at-point))
(account (ledger-context-field-value context 'account)))
(ledger-completing-read-with-default prompt
(when account
(regexp-quote account))
(ledger-accounts-list))))
(defun ledger-read-date (prompt)
"Return user-supplied date after `PROMPT', defaults to today.
This uses `org-read-date', which see."
(ledger-format-date (let ((org-read-date-prefer-future nil))
(org-read-date nil t nil prompt))))
(defun ledger-get-minibuffer-prompt (prompt default)
"Return a string composing of PROMPT and DEFAULT appropriate for a minibuffer prompt."
(concat prompt
(if default
(concat " (" default "): ")
": ")))
(defun ledger-completing-read-with-default (prompt default collection)
"Return a user supplied string after PROMPT, or DEFAULT while providing completions from COLLECTION."
(completing-read (ledger-get-minibuffer-prompt prompt default)
collection nil nil nil 'ledger-minibuffer-history default))
(defun ledger-read-string-with-default (prompt default)
"Return user supplied string after PROMPT, or DEFAULT."
(read-string (ledger-get-minibuffer-prompt prompt default)
nil 'ledger-minibuffer-history default))
(defun ledger-display-balance-at-point (&optional arg)
"Display the cleared-or-pending balance.
And calculate the target-delta of the account being reconciled.
With ARG (\\[universal-argument]) ask for the target commodity and convert
the balance into that."
(interactive "P")
(let* ((account (ledger-read-account-with-prompt "Account balance to show"))
(target-commodity (when arg (ledger-read-commodity-with-prompt "Target commodity: ")))
(buffer (find-file-noselect (ledger-master-file)))
(balance (with-temp-buffer
(apply 'ledger-exec-ledger buffer (current-buffer) "cleared" account
(when target-commodity (list "-X" target-commodity)))
(if (> (buffer-size) 0)
(buffer-substring-no-properties (point-min) (1- (point-max)))
(concat account " is empty.")))))
(when balance
(message balance))))
(defun ledger-display-ledger-stats ()
"Display the cleared-or-pending balance.
And calculate the target-delta of the account being reconciled."
(interactive)
(let* ((buffer (find-file-noselect (ledger-master-file)))
(balance (with-temp-buffer
(ledger-exec-ledger buffer (current-buffer) "stats")
(buffer-substring-no-properties (point-min) (1- (point-max))))))
(when balance
(message balance))))
(defvar ledger-mode-abbrev-table)
(defvar ledger-date-string-today (ledger-format-date))
(defun ledger-remove-effective-date ()
"Remove the effective date from a transaction or posting."
(interactive)
(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")))
(defun ledger-mode-clean-buffer ()
"Indent, remove multiple line feeds and sort the buffer."
(interactive)
(let ((start (point-min-marker))
(end (point-max-marker)))
(ledger-navigate-beginning-of-xact)
(beginning-of-line)
(let ((target (buffer-substring (point) (progn
(end-of-line)
(point)))))
(goto-char start)
(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 (kbd "C-c C-a") #'ledger-add-transaction)
(define-key map (kbd "C-c C-b") #'ledger-post-edit-amount)
(define-key map (kbd "C-c C-c") #'ledger-toggle-current)
(define-key map (kbd "C-c C-d") #'ledger-delete-current-transaction)
(define-key map (kbd "C-c C-e") #'ledger-toggle-current-transaction)
(define-key map (kbd "C-c C-f") #'ledger-occur)
(define-key map (kbd "C-c C-k") #'ledger-copy-transaction-at-point)
(define-key map (kbd "C-c C-r") #'ledger-reconcile)
(define-key map (kbd "C-c C-s") #'ledger-sort-region)
(define-key map (kbd "C-c C-t") #'ledger-insert-effective-date)
(define-key map (kbd "C-c C-u") #'ledger-schedule-upcoming)
(define-key map (kbd "C-c C-p") #'ledger-display-balance-at-point)
(define-key map (kbd "C-c C-l") #'ledger-display-ledger-stats)
(define-key map (kbd "C-c C-q") #'ledger-post-align-xact)
(define-key map (kbd "C-TAB") #'ledger-post-align-xact)
(define-key map (kbd "C-c TAB") #'ledger-fully-complete-xact)
(define-key map (kbd "C-c C-i") #'ledger-fully-complete-xact)
(define-key map (kbd "C-c C-o C-a") #'ledger-report-redo)
(define-key map (kbd "C-c C-o C-e") #'ledger-report-edit-report)
(define-key map (kbd "C-c C-o C-g") #'ledger-report-goto)
(define-key map (kbd "C-c C-o C-k") #'ledger-report-quit)
(define-key map (kbd "C-c C-o C-r") #'ledger-report)
(define-key map (kbd "C-c C-o C-s") #'ledger-report-save)
(define-key map (kbd "M-p") #'ledger-navigate-prev-xact-or-directive)
(define-key map (kbd "M-n") #'ledger-navigate-next-xact-or-directive)
(define-key map (kbd "M-q") #'ledger-post-align-dwim)
;; Reset the `text-mode' override of this standard binding
(define-key map (kbd "C-M-i") 'completion-at-point)
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]
["Check Buffer" ledger-check-buffer ledger-works]
["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))]
"---"
["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-report ledger-works]
["Quit Report" ledger-report-quit ledger-works]))
;;;###autoload
(define-derived-mode ledger-mode text-mode "Ledger"
"A mode for editing ledger data files."
(ledger-check-version)
(setq font-lock-defaults
'(ledger-font-lock-keywords t nil nil nil))
(add-hook 'font-lock-extend-region-functions 'ledger-fontify-extend-region)
(add-hook 'completion-at-point-functions #'ledger-complete-at-point nil t)
(add-hook 'after-save-hook 'ledger-report-redo nil t)
(add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t)
(ledger-init-load-init-file)
(setq-local comment-start ";")
(setq-local indent-line-function #'ledger-indent-line)
(setq-local indent-region-function 'ledger-post-align-postings))
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.ledger\\'" . ledger-mode))
(provide 'ledger-mode)
;;; ledger-mode.el ends here

1526
lisp/ledger-mode/ledger-mode.info Normal file
View File

File diff suppressed because it is too large Load Diff

199
lisp/ledger-mode/ledger-navigate.el Normal file
View File

@@ -0,0 +1,199 @@
;;; ledger-navigate.el --- Provide navigation services through the ledger buffer. -*- lexical-binding: t; -*-
;; 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 in case we are in the first line of an xact already.
(beginning-of-line)
(let ((sreg (concat "^[=~[:digit:]]")))
(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-skip-lines-backwards (re)
"Move backwards if necessary until RE does not match at the beginning of the line."
(beginning-of-line)
(while (and (looking-at-p re)
(zerop (forward-line -1)))))
(defun ledger-navigate-skip-lines-forwards (re)
"Move forwards if necessary until RE does not match at the beginning of the line."
(beginning-of-line)
(while (and (looking-at-p re)
(zerop (forward-line 1)))))
(defun ledger-navigate-find-directive-extents (pos)
"Return the extents of the directive at POS."
(goto-char pos)
(let ((begin (progn (ledger-navigate-skip-lines-backwards "[ \t]\\|end[[:blank:]]+\\(?:comment\\|test\\)")
(point)))
(end (progn (forward-line 1)
(ledger-navigate-skip-lines-forwards "[ \t]")
(1- (point))))
(comment-re " *;"))
;; handle block comments here
(goto-char begin)
(cond
((looking-at comment-re)
(progn
(ledger-navigate-skip-lines-backwards comment-re)
;; We are either at the beginning of the buffer, or we found
;; a line outside the comment, or both. If we are outside
;; the comment then we need to move forward a line.
(unless (looking-at comment-re)
(forward-line 1)
(beginning-of-line))
(setq begin (point))
(goto-char pos)
(ledger-navigate-skip-lines-forwards comment-re)
(setq end (point))))
((looking-at "\\(?:comment\\|test\\)\\>")
(setq end (or (save-match-data
(re-search-forward "^end[[:blank:]]+\\(?:comment\\|test\\)\\_>"))
(point-max)))))
(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)))
(comment-re " *;"))
;; handle block comments here
(beginning-of-line)
(if (looking-at comment-re)
(progn
(ledger-navigate-skip-lines-backwards comment-re)
(setq begin (point))
(goto-char pos)
(beginning-of-line)
(ledger-navigate-skip-lines-forwards comment-re)
(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)
(ledger-navigate-skip-lines-backwards "[ \t]\\|end[[:blank:]]+\\(?:comment\\|test\\)\\_>")
(if (looking-at "[=~0-9\\[]")
(ledger-navigate-find-xact-extents pos)
(ledger-navigate-find-directive-extents pos))))
(defun ledger-navigate-next-uncleared ()
"Move point to the next uncleared transaction."
(interactive)
(when (looking-at ledger-payee-uncleared-regex)
(forward-line))
(if (re-search-forward ledger-payee-uncleared-regex nil t)
(progn (beginning-of-line)
(point))
(user-error "No next uncleared transactions")))
(defun ledger-navigate-previous-uncleared ()
"Move point to the previous uncleared transaction."
(interactive)
(when (equal (car (ledger-context-at-point)) 'acct-transaction)
(ledger-navigate-beginning-of-xact))
(if (re-search-backward ledger-payee-uncleared-regex nil t)
(progn (beginning-of-line)
(point))
(user-error "No previous uncleared transactions")))
(provide 'ledger-navigate)
;;; ledger-navigate.el ends here

169
lisp/ledger-mode/ledger-occur.el Normal file
View File

@@ -0,0 +1,169 @@
;;; ledger-occur.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; Provide buffer narrowing to ledger mode. Adapted from original loccur
;; mode by Alexey Veretennikov <alexey dot veretennikov at gmail dot
;; com>
;;
;; Adapted to ledger mode by Craig Earls <enderww at gmail dot
;; com>
;;; Code:
(require 'cl-lib)
(require 'ledger-navigate)
(defconst ledger-occur-overlay-property-name 'ledger-occur-custom-buffer-grep)
(defcustom ledger-occur-use-face-shown t
"If non-nil, use a custom face for xacts shown in `ledger-occur' mode using ledger-occur-xact-face."
:type 'boolean
:group 'ledger)
(make-variable-buffer-local 'ledger-occur-use-face-shown)
(defvar ledger-occur-history nil
"History of previously searched expressions for the prompt.")
(defvar ledger-occur-current-regex nil
"Pattern currently applied to narrow the buffer.")
(make-variable-buffer-local 'ledger-occur-current-regex)
(defvar ledger-occur-mode-map (make-sparse-keymap))
(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")))
(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-refresh ()
"Re-apply the current narrowing expression."
(interactive)
(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)
"Show only transactions in the current buffer which match REGEX.
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
(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"
(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)
(when ledger-occur-use-face-shown
(overlay-put ovl 'font-lock-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)))
(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 (cl-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))
(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 (endpoint lines bounds)
;; Search loop
(while (not (eobp))
;; if something found
(when (setq endpoint (re-search-forward regex nil 'end))
(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"
(if buffer-matches
(let ((points (list))
(current-beginning (caar buffer-matches))
(current-end (cl-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)
;;; ledger-occur.el ends here

183
lisp/ledger-mode/ledger-post.el Normal file
View File

@@ -0,0 +1,183 @@
;;; ledger-post.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; Utility functions for dealing with postings.
(require 'ledger-regex)
(require 'ledger-navigate)
;;; Code:
(defgroup ledger-post nil
"Options for controlling how Ledger-mode deals with postings and completion"
:group 'ledger)
(defcustom ledger-post-account-alignment-column 4
"The column Ledger-mode attempts to align accounts to."
:type 'integer
:group 'ledger-post)
(defcustom ledger-post-amount-alignment-column 52
"The column Ledger-mode attempts to align amounts to."
:type 'integer
:group 'ledger-post)
(defcustom ledger-post-amount-alignment-at :end
"Position at which the amount is aligned.
Can be :end to align on the last number of the amount (can be
followed by unaligned commodity) or :decimal to align at the
decimal separator."
:type '(radio (const :tag "align at the end of amount" :end)
(const :tag "align at the decimal separator" :decimal))
:group 'ledger-post)
(defcustom ledger-post-auto-align t
"When non-nil, realign post amounts when indenting or completing."
:type 'boolean
:group 'ledger-post
:package-version '(ledger-mode . "4.0.0")
:safe 'booleanp)
(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."
;;(beginning-of-line)
(let ((case-fold-search nil))
(when (re-search-forward ledger-amount-regex end t)
(goto-char (match-beginning 0))
(skip-syntax-forward " ")
(cond
((eq ledger-post-amount-alignment-at :end)
(- (or (match-end 4) (match-end 3)) (point)))
((eq ledger-post-amount-alignment-at :decimal)
(- (match-end 3) (point)))))))
(defun ledger-next-account (&optional end)
"Move to the beginning of the posting, or status marker.
Return the column of the beginning of the account and leave point
at beginning of account.
Looks only as far as END, if supplied, otherwise `point-max'."
(let ((end (or end (point-max))))
(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-navigate-find-xact-extents pos)))
(ledger-post-align-postings (car bounds) (cadr bounds))))
(defun ledger-post-align-postings (beg end)
"Align all accounts and amounts between BEG and END, or the current region, or, if no region, the current line."
(interactive "r")
(save-match-data
(save-excursion
(let ((inhibit-modification-hooks t)
;; Extend region to whole lines
(beg (save-excursion (goto-char beg) (line-beginning-position)))
(end (save-excursion (goto-char end) (move-end-of-line 1) (point-marker))))
(untabify beg end)
(goto-char beg)
(while (< (point) end)
(when (looking-at-p " ")
;; fix spaces at beginning of line:
(just-one-space ledger-post-account-alignment-column)
;; fix spaces before amount if any:
(when (re-search-forward "\t\\| \\| \t" (line-end-position) t)
(goto-char (match-beginning 0))
(let ((acct-end-column (current-column))
(amt-width (ledger-next-amount (line-end-position)))
amt-adjust)
(when amt-width
(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 1))))))
(defun ledger-indent-line ()
"Indent the current line."
;; Ensure indent if the previous line was indented
(let ((indent-level (save-excursion (if (and (zerop (forward-line -1))
(memq (ledger-thing-at-point) '(transaction posting)))
ledger-post-account-alignment-column
0))))
(unless (= (current-indentation) indent-level)
(back-to-indentation)
(delete-horizontal-space t)
(indent-to indent-level)))
(when ledger-post-auto-align
(ledger-post-align-postings (line-beginning-position) (line-end-position))))
(defun ledger-post-align-dwim ()
"Align all the posting of the current xact or the current region.
If the point is in a comment, fill the comment paragraph as
regular text."
(interactive)
(cond
((nth 4 (syntax-ppss))
(call-interactively 'ledger-post-align-postings)
(fill-paragraph))
((use-region-p) (call-interactively 'ledger-post-align-postings))
(t (call-interactively 'ledger-post-align-xact))))
(defun ledger-post-edit-amount ()
"Call 'calc-mode' and push the amount in the posting to the top of stack."
(interactive)
(goto-char (line-beginning-position))
(when (re-search-forward ledger-post-line-regexp (line-end-position) t)
(goto-char (match-end ledger-regex-post-line-group-account)) ;; go to the and of the account
(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-string (match-string 0)))
(goto-char (match-beginning 0))
(delete-region (match-beginning 0) (match-end 0))
(push-mark)
(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 " "))
(push-mark)
(calc))))))
(provide 'ledger-post)
;;; ledger-post.el ends here

640
lisp/ledger-mode/ledger-reconcile.el Normal file
View File

@@ -0,0 +1,640 @@
;;; ledger-reconcile.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;; Reconcile mode
;;; Commentary:
;; Code to handle reconciling Ledger files with outside sources
;;; Code:
(require 'easymenu)
(require 'ledger-init)
(require 'ledger-xact)
(require 'ledger-occur)
(require 'ledger-commodities)
(require 'ledger-exec)
(require 'ledger-navigate)
(require 'ledger-state)
(declare-function ledger-insert-effective-date "ledger-mode" (&optional date))
(declare-function ledger-read-account-with-prompt "ledger-mode" (prompt))
(declare-function ledger-read-date "ledger-mode" (prompt))
(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"
:group 'ledger)
(defcustom ledger-recon-buffer-name "*Reconcile*"
"Name to use for reconciliation buffer."
:type 'string
:group 'ledger-reconcile)
(defcustom ledger-narrow-on-reconcile t
"If t, limit transactions shown in main buffer to those matching the reconcile regex."
:type 'boolean
:group 'ledger-reconcile)
(defcustom ledger-buffer-tracks-reconcile-buffer t
"If t, move point in the ledger buffer when it moves in the reconcile buffer.
When the cursor is moved to a new transaction in the reconcile
buffer then that transaction will be shown in its source buffer."
:type 'boolean
:group 'ledger-reconcile)
(defcustom ledger-reconcile-force-window-bottom nil
"If t, make the reconcile window appear along the bottom of the register window and resize."
:type 'boolean
:group 'ledger-reconcile)
(defcustom ledger-reconcile-toggle-to-pending t
"If t, then toggle between uncleared and pending.
reconcile-finish will mark all pending posting cleared."
:type 'boolean
:group 'ledger-reconcile)
(defcustom ledger-reconcile-default-date-format ledger-default-date-format
"Date format for the reconcile buffer.
Default is `ledger-default-date-format'."
:type 'string
:group 'ledger-reconcile)
(defcustom ledger-reconcile-target-prompt-string "Target amount for reconciliation "
"Prompt for recon target."
:type 'string
:group 'ledger-reconcile)
(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 will be 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
preceded by a minus sign which mean to left justify and pad the
field. WIDTH is the minimum number of characters to display;
if string is longer, it is not truncated unless
`ledger-reconcile-buffer-payee-max-chars' or
`ledger-reconcile-buffer-account-max-chars' is defined."
:type 'string
:group 'ledger-reconcile)
(defcustom ledger-reconcile-buffer-payee-max-chars -1
"If positive, truncate payee name right side to max number of characters."
:type 'integer
:group 'ledger-reconcile)
(defcustom ledger-reconcile-buffer-account-max-chars -1
"If positive, truncate account name left side to max number of characters."
:type 'integer
:group 'ledger-reconcile)
(defcustom ledger-reconcile-sort-key "(0)"
"Key for sorting reconcile buffer.
Possible values are '(date)', '(amount)', '(payee)' or '(0)' for no sorting, i.e. using ledger file order."
: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)
(defcustom ledger-reconcile-finish-force-quit nil
"If t, will force closing reconcile window after \\[ledger-reconcile-finish]."
:type 'boolean
:group 'ledger-reconcile)
;; s-functions below are copied from Magnars' s.el
;; prefix ledger-reconcile- is added to not conflict with s.el
(defun ledger-reconcile-s-pad-left (len padding s)
"If S is shorter than LEN, pad it with PADDING on the left."
(let ((extra (max 0 (- len (length s)))))
(concat (make-string extra (string-to-char padding))
s)))
(defun ledger-reconcile-s-pad-right (len padding s)
"If S is shorter than LEN, pad it with PADDING on the right."
(let ((extra (max 0 (- len (length s)))))
(concat s
(make-string extra (string-to-char padding)))))
(defun ledger-reconcile-s-left (len s)
"Return up to the LEN first chars of S."
(if (> (length s) len)
(substring s 0 len)
s))
(defun ledger-reconcile-s-right (len s)
"Return up to the LEN last chars of S."
(let ((l (length s)))
(if (> l len)
(substring s (- l len) l)
s)))
(defun ledger-reconcile-truncate-right (str len)
"Truncate STR right side with max LEN characters, and pad with '…' if truncated."
(if (and (>= len 0) (> (length str) len))
(ledger-reconcile-s-pad-right len "…" (ledger-reconcile-s-left (- len 1) str))
str))
(defun ledger-reconcile-truncate-left (str len)
"Truncate STR left side with max LEN characters, and pad with '…' if truncated."
(if (and (>= len 0) (> (length str) len))
(ledger-reconcile-s-pad-left len "…" (ledger-reconcile-s-right (- len 1) str))
str))
(defun ledger-reconcile-get-cleared-or-pending-balance (buffer 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
(with-temp-buffer
;; note that in the line below, the --format option is
;; separated from the actual format string. emacs does not
;; split arguments like the shell does, so you need to
;; specify the individual fields in the command line.
(ledger-exec-ledger buffer (current-buffer)
"balance" "--real" "--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.
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 "Cleared and Pending balance: %s, Difference from target: %s"
(ledger-commodity-to-string pending)
(ledger-commodity-to-string (ledger-subtract-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 "")
(equal file "<stdin>")
(equal file "/dev/stdin")))
(defun ledger-reconcile-get-buffer (where)
"Return a buffer from WHERE the transaction is."
(if (bufferp (car where))
(car where)
(error "Function ledger-reconcile-get-buffer: Buffer not set")))
(defun ledger-reconcile-toggle ()
"Toggle the current transaction, and mark the recon window."
(interactive)
(beginning-of-line)
(let ((where (get-text-property (point) 'where))
(inhibit-read-only t)
status)
(when (ledger-reconcile-get-buffer where)
(with-current-buffer (ledger-reconcile-get-buffer where)
(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 'font-lock-face))
(cond ((eq status 'pending)
(add-text-properties (line-beginning-position)
(line-end-position)
(list 'font-lock-face 'ledger-font-reconciler-pending-face )))
((eq status 'cleared)
(add-text-properties (line-beginning-position)
(line-end-position)
(list 'font-lock-face 'ledger-font-reconciler-cleared-face )))
(t
(add-text-properties (line-beginning-position)
(line-end-position)
(list 'font-lock-face 'ledger-font-reconciler-uncleared-face )))))
(forward-line)
(beginning-of-line)
(ledger-display-balance)))
(defun ledger-reconcile-refresh ()
"Force the reconciliation window to refresh.
Return the number of uncleared xacts found."
(interactive)
(let ((inhibit-read-only t)
(line (count-lines (point-min) (point))))
(erase-buffer)
(prog1
(ledger-do-reconcile ledger-reconcile-sort-key)
(set-buffer-modified-p t)
(ledger-reconcile-ensure-xacts-visible)
(goto-char (point-min))
(forward-line line))))
(defun ledger-reconcile-refresh-after-save ()
"Refresh the recon-window after the ledger buffer is saved."
(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))
(when curbufwin
(select-window curbufwin)
(goto-char curpoint)
(recenter)
(ledger-highlight-xact-under-point)))))
(defun ledger-reconcile-add ()
"Use ledger xact to add a new transaction."
(interactive)
(with-current-buffer ledger-buf
(let ((date (ledger-read-date "Date: "))
(text (read-string "Transaction: ")))
(ledger-add-transaction (concat date " " text))))
(ledger-reconcile-refresh))
(defun ledger-reconcile-delete ()
"Delete the transactions pointed to in the recon window."
(interactive)
(let ((where (get-text-property (point) 'where)))
(when (ledger-reconcile-get-buffer where)
(with-current-buffer (ledger-reconcile-get-buffer where)
(ledger-navigate-to-line (cdr where))
(ledger-delete-current-transaction (point)))
(let ((inhibit-read-only t))
(delete-region (line-beginning-position)
(min (1+ (line-end-position)) (point-max)))
(set-buffer-modified-p t))
(ledger-reconcile-refresh)
(ledger-reconcile-visit t))))
(defun ledger-reconcile-visit (&optional come-back)
"Recenter ledger buffer on transaction and COME-BACK if non-nil."
(interactive)
(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)
(with-selected-window (selected-window) ; restoring window is needed because after-save-hook will modify window and buffers
(dolist (buf (cons ledger-buf ledger-bufs))
(with-current-buffer buf
(basic-save-buffer)))))
(defun ledger-reconcile-finish ()
"Mark all pending posting or transactions as cleared.
Depends on ledger-reconcile-clear-whole-transactions, save the buffers
and exit reconcile mode if `ledger-reconcile-finish-force-quit'"
(interactive)
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(let ((where (get-text-property (point) 'where))
(face (get-text-property (point) 'font-lock-face)))
(if (eq face 'ledger-font-reconciler-pending-face)
(with-current-buffer (ledger-reconcile-get-buffer where)
(ledger-navigate-to-line (cdr where))
(ledger-toggle-current 'cleared))))
(forward-line 1)))
(ledger-reconcile-save)
(when ledger-reconcile-finish-force-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)
(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)))))
(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-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 (ledger-is-stdin (nth 0 emacs-xact))
ledger-buf
(find-file-noselect (nth 0 emacs-xact)))))
(cons
buf
(if (or ledger-clear-whole-transactions
;; The posting might not be part of the ledger buffer. This can
;; happen if the account to reconcile is the default account. In
;; that case, we just behave as if ledger-clear-whole-transactions
;; was turned on. See #58 for more info.
(= -1 (nth 0 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 (cl-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 'font-lock-face 'ledger-font-reconciler-pending-face
'where where))
(set-text-properties beg (1- (point))
(list 'font-lock-face 'ledger-font-reconciler-cleared-face
'where where)))
(set-text-properties beg (1- (point))
(list 'font-lock-face 'ledger-font-reconciler-uncleared-face
'where where))))
(defun ledger-reconcile-format-xact (xact fmt)
"Format XACT using FMT."
(dolist (posting (nthcdr 5 xact))
(let ((beg (point))
(where (ledger-marker-where-xact-is xact posting)))
(ledger-reconcile-format-posting beg
where
fmt
(ledger-format-date (nth 2 xact)) ; date
(if (nth 3 xact) (nth 3 xact) "") ; code
(nth 3 posting) ; status
(ledger-reconcile-truncate-right
(nth 4 xact) ; payee
ledger-reconcile-buffer-payee-max-chars)
(ledger-reconcile-truncate-left
(nth 1 posting) ; account
ledger-reconcile-buffer-account-max-chars)
(nth 2 posting))))) ; amount
(defun ledger-do-reconcile (&optional sort)
"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)
(sort-by (if sort
sort
"(date)"))
(xacts
(with-temp-buffer
(ledger-exec-ledger buf (current-buffer)
"--uncleared" "--real" "emacs" "--sort" sort-by account)
(goto-char (point-min))
(unless (eobp)
(if (looking-at "(")
(read (current-buffer))))))
(fmt (ledger-reconcile-compile-format-string ledger-reconcile-buffer-line-format)))
(if (> (length xacts) 0)
(progn
(if ledger-reconcile-buffer-header
(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
(insert (concat "There are no uncleared entries for " account)))
(goto-char (point-min))
(set-buffer-modified-p nil)
(setq buffer-read-only t)
(length xacts)))
(defun ledger-reconcile-ensure-xacts-visible ()
"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 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)))
(recenter))
(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)))
(save-excursion
(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)))
(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 (&optional account target)
"Start reconciling, prompt for ACCOUNT."
(interactive)
(let ((account (or account (ledger-read-account-with-prompt "Account to reconcile")))
(buf (current-buffer))
(rbuf (get-buffer ledger-recon-buffer-name)))
(when (ledger-reconcile-check-valid-account account)
(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)))
;; no recon-buffer, starting from scratch.
(with-current-buffer (setq rbuf
(get-buffer-create ledger-recon-buffer-name))
(ledger-reconcile-open-windows buf rbuf)
(ledger-reconcile-mode)
(make-local-variable 'ledger-target)
(set (make-local-variable 'ledger-buf) buf)
(set (make-local-variable 'ledger-acct) account)))
(add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save nil t)
;; 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 target))
(ledger-display-balance)))))
(defvar ledger-reconcile-mode-abbrev-table)
(defun ledger-reconcile-change-target (&optional target)
"Change the TARGET amount for the reconciliation process."
(interactive)
(setq ledger-target (or 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)))
(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.")
(provide 'ledger-reconcile)
;;; ledger-reconcile.el ends here

413
lisp/ledger-mode/ledger-regex.el Normal file
View File

@@ -0,0 +1,413 @@
;;; ledger-regex.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; Regular expressions used by ledger-mode.
;;; Code:
(require 'rx)
(require 'cl-lib)
(defvar ledger-iso-date-regex)
(defconst ledger-amount-decimal-comma-regex
"-?[1-9][0-9.]*[,]?[0-9]*")
(defconst ledger-amount-decimal-period-regex
"-?[1-9][0-9,]*[.]?[0-9]*")
(defconst ledger-other-entries-regex
"\\(^[~=A-Za-z].+\\)+")
(defconst ledger-comment-regex
"^[;#|\\*%].*\\|[ \t]+;.*")
(defconst ledger-multiline-comment-start-regex
"^!comment$")
(defconst ledger-multiline-comment-end-regex
"^!end_comment$")
(defconst ledger-multiline-comment-regex
"^!comment\n\\(.*\n\\)*?!end_comment$")
(defconst ledger-payee-any-status-regex
"^[0-9]+[-/][-/.=0-9]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.+?\\)\\s-*\\(;\\|$\\)")
(defconst ledger-payee-pending-regex
"^[0-9]+[-/][-/.=0-9]+\\s-!\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\s-*\\(;\\|$\\)")
(defconst ledger-payee-cleared-regex
"^[0-9]+[-/][-/.=0-9]+\\s-\\*\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\s-*\\(;\\|$\\)")
(defconst ledger-payee-uncleared-regex
"^[0-9]+[-/][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\s-*\\(;\\|$\\)")
(defconst ledger-init-string-regex
"^--.+?\\($\\|[ ]\\)")
(defconst ledger-account-name-regex
"\\(?1:[^][(); \t\r\n]+\\(?: [^][(); \t\r\n]+\\)*\\)")
(defconst ledger-account-directive-regex
(concat "^account[ \t]+" ledger-account-name-regex))
(defconst ledger-account-name-maybe-virtual-regex
(concat "[[(]?" ledger-account-name-regex "[])]?"))
(defconst ledger-account-any-status-regex
(concat "^[ \t]+\\(?:[!*][ \t]*\\)?" ledger-account-name-maybe-virtual-regex))
;; This would incorrectly match "account (foo)", but writing the regexp this way
;; allows us to have just one match result
(defconst ledger-account-name-or-directive-regex
(format "\\(?:%s\\|%s\\)" ledger-account-any-status-regex ledger-account-directive-regex))
(defconst ledger-account-pending-regex
(concat "\\(^[ \t]+\\)!" ledger-account-name-maybe-virtual-regex))
(defconst ledger-account-cleared-regex
(concat "\\(^[ \t]+\\)*" ledger-account-name-maybe-virtual-regex))
(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)
,docs)))
(addend 0) last-group)
(if (null args)
(progn
(nconc
defs
(list
`(defconst
,(intern
(concat "ledger-regex-" (symbol-name name) "-group"))
1)))
(nconc
defs
(list
`(defconst
,(intern (concat "ledger-regex-" (symbol-name name)
"-group--count"))
1)))
(nconc
defs
(list
`(defmacro
,(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)
(cl-assert (listp arg))
(if (= 2 (length arg))
(setq var (car arg)
target (cadr arg))
(setq var (car arg)
grouping (cadr arg)
target (cl-caddr arg))))
(if (and last-group
(not (eq last-group (or grouping target))))
(cl-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 'eval-and-compile 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.")
(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))
(ledger-define-regexp state
(rx (group (any ?! ?*)))
"Match a transaction or posting's \"state\" character.")
(ledger-define-regexp 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\".")
(ledger-define-regexp note
(rx (group (+ nonl)))
"")
(ledger-define-regexp end-note
(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))))
"")
(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))
(ledger-define-regexp recurring-line
(macroexpand
`(rx (and line-start
(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))))
"")
(ledger-define-regexp account-kind
(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))
(ledger-define-regexp commodity-no-group
(rx (or (and ?\" (+ (not (any ?\"))) ?\")
(+ (not (any blank ?\n
digit
?- ?\[ ?\]
?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?=
?\< ?\> ?\{ ?\} ?\( ?\) ?@)))))
"")
(ledger-define-regexp commodity
(macroexpand
`(rx (group (regexp ,ledger-commodity-no-group-regexp))))
"")
(ledger-define-regexp amount-no-group
(rx (and (? ?-)
(+ digit)
(*? (and (any ?. ?,) (+ digit)))))
"")
(ledger-define-regexp amount
(macroexpand
`(rx (group (regexp ,ledger-amount-no-group-regexp))))
"")
(ledger-define-regexp commoditized-amount
(macroexpand
`(rx (group
(or (and (regexp ,ledger-commodity-no-group-regexp)
(*? blank)
(regexp ,ledger-amount-no-group-regexp))
(and (regexp ,ledger-amount-no-group-regexp)
(*? blank)
(regexp ,ledger-commodity-no-group-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 ?\))) ?\))))))
"")
(ledger-define-regexp cost
(macroexpand
`(rx (and (or "@" "@@") (+ blank)
(regexp ,ledger-commoditized-amount-regexp))))
"")
(ledger-define-regexp balance-assertion
(macroexpand
`(rx (and ?= (+ blank)
(regexp ,ledger-commoditized-amount-regexp))))
"")
(ledger-define-regexp full-amount
(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))
(defconst ledger-amount-regex
(concat "\\( \\|\t\\| \t\\)[ \t]*-?"
"\\(?:" ledger-commodity-regexp " *\\)?"
;; We either match just a number after the commodity with no
;; decimal or thousand separators or a number with thousand
;; separators. If we have a decimal part starting with `,'
;; or `.', because the match is non-greedy, it must leave at
;; least one of those symbols for the following capture
;; group, which then finishes the decimal part.
"\\(-?\\(?:[0-9]+\\|[0-9,.]+?\\)\\)"
"\\([,.][0-9)]+\\)?"
"\\(?: *" ledger-commodity-regexp "\\)?"
"\\([ \t]*[@={]@?[^\n;]+?\\)?"
"\\([ \t]+;.+?\\|[ \t]*\\)?$"))
(defconst ledger-iterate-regex
(concat "\\(\\(?:Y\\|year\\)\\s-+\\([0-9]+\\)\\|" ;; Catches a Y/year directive
ledger-iso-date-regexp
"\\([ *!]+\\)" ;; mark
"\\((.*)\\)?" ;; code
"\\([[:word:] ]+\\)" ;; desc
"\\)"))
(defconst ledger-incomplete-date-regexp
"\\(?:\\([0-9]\\{1,2\\}\\)[-/]\\)?\\([0-9]\\{1,2\\}\\)")
(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]+\\(.+?\\)\\)?" ;; desc, subexp 3
"\\(?:\\(?:\t\\|[ \t]\\{2,\\}\\)\\(;[^\n]*\\)\\)?$" ;; comment, subexp 4
))
(defconst ledger-posting-regex
(concat "^[[:blank:]]+" ; initial white space
"\\(\\([*!]\\)?" ; state and account 1, state 2
"[[:blank:]]*\\(.*?\\)\\)?" ; account 3
"\\(?:\t\\|[[:blank:]]\\{2,\\}" ; column separator
"\\([^;\n]*?\\)" ; amount 4
"[[:blank:]]*\\(;.*\\)?\\)?$" ; comment 5
))
(defconst ledger-directive-start-regex
"[=~;#%|\\*[A-Za-z]")
(provide 'ledger-regex)
;;; ledger-regex.el ends here

672
lisp/ledger-mode/ledger-report.el Normal file
View File

@@ -0,0 +1,672 @@
;;; ledger-report.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; Provide facilities for running and saving reports in Emacs
;;; Code:
(require 'ledger-xact)
(require 'ledger-navigate)
(require 'ledger-commodities)
(declare-function ledger-read-string-with-default "ledger-mode" (prompt default))
(declare-function ledger-read-account-with-prompt "ledger-mode" (prompt))
(require 'easymenu)
(require 'ansi-color)
(require 'font-lock)
(eval-when-compile
(require 'rx)
(require 'subr-x))
(defvar ledger-buf)
(defgroup ledger-report nil
"Customization option for the Report buffer"
:group 'ledger)
(defcustom ledger-reports
'(("bal" "%(binary) -f %(ledger-file) bal")
("reg" "%(binary) -f %(ledger-file) reg")
("payee" "%(binary) -f %(ledger-file) reg @%(payee)")
("account" "%(binary) -f %(ledger-file) reg %(account)"))
"Definition of reports to run.
Each element has the form (NAME CMDLINE). The command line can
contain format specifiers that are replaced with context sensitive
information. Format specifiers have the format '%(<name>)' where
<name> is an identifier for the information to be replaced. The
`ledger-report-format-specifiers' alist variable contains a mapping
from format specifier identifier to a Lisp function that implements
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")))
:group 'ledger-report)
(defcustom ledger-report-format-specifiers
'(("ledger-file" . ledger-report-ledger-file-format-specifier)
("binary" . ledger-report-binary-format-specifier)
("payee" . ledger-report-payee-format-specifier)
("account" . ledger-report-account-format-specifier)
("month" . ledger-report-month-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
a string, or a list of strings, that should replace the format specifier.
Single strings are quoted with `shell-quote-argument'; lists of strings are
simply concatenated (no quoting)."
:type 'alist
:group 'ledger-report)
(defcustom ledger-report-auto-refresh t
"If non-nil, automatically rerun the report when the ledger buffer is saved."
:type 'boolean
:group 'ledger-report)
(defcustom ledger-report-auto-refresh-sticky-cursor nil
"If non-nil, place cursor at same relative position as it was before auto-refresh."
:type 'boolean
:group 'ledger-report)
(defcustom ledger-report-links-in-register t
"If non-nil, link entries in \"register\" reports to entries in the ledger buffer."
:type 'boolean
:group 'ledger-report)
(defcustom ledger-report-use-native-highlighting t
"When non-nil, use ledger's native highlighting in reports."
:type 'boolean
:package-version '(ledger-mode . "4.0.0")
:group 'ledger-report)
(defcustom ledger-report-auto-width t
"When non-nil, tell ledger about the width of the report window."
:type 'boolean
:package-version '(ledger-mode . "4.0.0")
:group 'ledger-report)
(defcustom ledger-report-use-header-line nil
"If non-nil, indicate report name/command in the `header-line'.
The report name/command won't be printed in the buffer. See
`ledger-report-header-line-fn' for how to customize the
information reported."
:type 'boolean
:package-version '(ledger-mode . "4.0.0")
:group 'ledger-report)
(defcustom ledger-report-header-line-fn #'ledger-report--header-function
"Evaluate this function in the `header-line' of the report buffer.
`ledger-report-use-header-line' must be non-nil for this to have any effect."
:type 'function
:package-version '(ledger-mode . "4.0.0")
:group 'ledger-report)
(defcustom ledger-report-resize-window t
"If non-nil, resize the report window.
Calls `shrink-window-if-larger-than-buffer'."
:type 'boolean
:package-version '(ledger-mode . "4.0.0")
:group 'ledger-report)
(defcustom ledger-report-use-strict nil
"When non-nil, `ledger-mode' will use --strict when running reports?"
:type 'boolean
:package-version '(ledger-mode . "4.0.0")
:group 'ledger-report)
(defcustom ledger-report-after-report-hook nil
"Hook run after `ledger-report' has created the buffer and report."
:type 'boolean
:package-version '(ledger-mode . "4.0.0")
:group 'ledger-report)
(defvar ledger-report-buffer-name "*Ledger Report*")
(defvar ledger-report-name nil)
(defvar ledger-report-cmd nil)
(defvar ledger-report-name-prompt-history nil)
(defvar ledger-report-cmd-prompt-history nil)
(defvar ledger-original-window-cfg nil)
(defvar ledger-report-saved nil)
(defvar ledger-minibuffer-history nil)
(defvar ledger-report-mode-abbrev-table)
(defvar ledger-report-current-month nil)
(defvar ledger-report-is-reversed nil)
(defvar ledger-report-cursor-line-number nil)
(defvar-local ledger-master-file nil
"The master file for the current buffer.
See documentation for the function `ledger-master-file'")
(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 ()
"Reverse the lines in the ledger report buffer."
(with-silent-modifications
(goto-char (point-min))
(unless ledger-report-use-header-line
(forward-paragraph)
(forward-line))
(save-excursion
(reverse-region (point) (point-max)))))
(defun ledger-report-maybe-shrink-window ()
"Shrink window if `ledger-report-resize-window' is non-nil."
(when ledger-report-resize-window
(shrink-window-if-larger-than-buffer)))
(defvar ledger-report-mode-map
(let ((map (make-sparse-keymap)))
(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 [(shift ?s)] #'ledger-report)
(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 [(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 ?e)]
#'ledger-report-edit-report)
(define-key map [(control ?c) (control ?o) (control ?r)] #'ledger-report)
(define-key map (kbd "M-p") #'ledger-report-previous-month)
(define-key map (kbd "M-n") #'ledger-report-next-month)
(define-key map (kbd "$") #'ledger-report-toggle-default-commodity)
map)
"Keymap for `ledger-report-mode'.")
(easy-menu-define ledger-report-mode-menu ledger-report-mode-map
"Ledger report menu"
'("Reports"
["Select Report" ledger-report]
["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 special-mode "Ledger-Report"
"A mode for viewing ledger reports."
(setq-local revert-buffer-function #'ledger-report-redo)
(hack-dir-local-variables-non-file-buffer))
(defconst ledger-report--extra-args-marker "[[ledger-mode-flags]]")
(defun ledger-report-binary-format-specifier ()
"Return the path to ledger, plus a marker for extra arguments."
(list (shell-quote-argument ledger-binary-path)
ledger-report--extra-args-marker))
(defun ledger-report-tagname-format-specifier ()
"Return a valid meta-data tag name."
;; It is intended completion should be available on existing tag
;; names, but it remains to be implemented.
(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 tag
;; values, 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.
The empty string and unknown names are allowed."
(completing-read "Report name: "
ledger-reports nil nil nil
'ledger-report-name-prompt-history nil))
(defun ledger-report (report-name edit)
"Run a user-specified report from `ledger-reports'.
Prompts the user for the REPORT-NAME of the report to run or
EDIT. If no name is entered, the user will be prompted for a
command line to run. The command line specified or associated
with the selected report name is run and the output is made
available in another buffer for viewing. If a prefix argument is
given and the user selects a valid report name, the user is
prompted with the corresponding command line for editing before
the command is run.
The output buffer will be in `ledger-report-mode', which defines
commands for saving a new named report based on the command line
used to generate the buffer, navigating the buffer, etc."
(interactive
(progn
(when (and (buffer-modified-p)
(y-or-n-p "Buffer modified, save it? "))
(save-buffer))
(let ((rname (ledger-report-read-name))
(edit (not (null current-prefix-arg))))
(list rname edit))))
(let* ((file (ledger-master-file))
(buf (find-file-noselect file))
(wcfg (current-window-configuration)))
(with-current-buffer
(pop-to-buffer (get-buffer-create ledger-report-buffer-name))
(with-silent-modifications
(erase-buffer)
(ledger-report-mode)
(set (make-local-variable 'ledger-report-saved) nil)
(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)
(set (make-local-variable 'ledger-report-current-month) nil)
(set 'ledger-master-file file)
(ledger-do-report (ledger-report-cmd report-name edit)))
(ledger-report-maybe-shrink-window)
(run-hooks 'ledger-report-after-report-hook)
(message (substitute-command-keys (concat "\\[ledger-report-quit] to quit; "
"\\[ledger-report-redo] to redo; "
"\\[ledger-report-edit-report] to edit; "
"\\[ledger-report-save] to save; "
"\\[scroll-up-command] and \\[scroll-down-command] to scroll"))))))
(defun ledger-report--header-function ()
"Compute the string to be used as the header in the `ledger-report' buffer."
(format "Ledger Report: %s -- Buffer: %s -- Command: %s"
(propertize ledger-report-name 'face 'font-lock-constant-face)
(propertize (buffer-name ledger-buf) 'face 'font-lock-string-face)
(propertize ledger-report-cmd 'face 'font-lock-comment-face)))
(defun ledger-report-string-empty-p (s)
"Check S for the empty string."
(string-equal "" s))
(defun ledger-report-name-exists (name)
"Check to see if the given report NAME exists.
If name exists, returns the object naming the report,
otherwise returns nil."
(unless (ledger-report-string-empty-p name)
(car (assoc name ledger-reports))))
(defun ledger-reports-add (name cmd)
"Add a new report NAME and CMD to `ledger-reports'."
(setq ledger-reports (cons (list name cmd) ledger-reports)))
(defun ledger-reports-custom-save ()
"Save the `ledger-reports' variable using the customize framework."
(customize-save-variable 'ledger-reports ledger-reports))
(defun ledger-report-read-command (report-cmd)
"Read the command line to create a report from REPORT-CMD."
(read-from-minibuffer "Report command line: "
(if (null report-cmd) "ledger " report-cmd)
nil nil 'ledger-report-cmd-prompt-history))
(defun ledger-report-ledger-file-format-specifier ()
"Substitute the full path to master or current ledger file.
The master file name is determined by the variable `ledger-master-file'
buffer-local variable which can be set using file variables.
If it is set, it is used, otherwise the current buffer file is
used."
(ledger-master-file))
;; General helper functions
(defun ledger-master-file ()
"Return the master file for a ledger file.
The master file is either the file for the current ledger buffer or the
file specified by the buffer-local variable `ledger-master-file'. Typically
this variable would be set in a file local variable comment block at the
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)))
(defun ledger-report-payee-format-specifier ()
"Substitute a payee name.
The user is prompted to enter a payee and that is substitued. If
point is in an xact, the payee for that xact is used as the
default."
;; It is intended completion should be available on existing
;; payees, but the list of possible completions needs to be
;; developed to allow this.
(if-let ((payee (ledger-xact-payee)))
(ledger-read-string-with-default "Payee" (regexp-quote payee))
(ledger-read-string-with-default "Payee" nil)))
(defun ledger-report-account-format-specifier ()
"Substitute an account name.
The user is prompted to enter an account name, which can be any
regular expression identifying an account. If point is on an account
posting line for an xact, the full account name on that line is
the default."
(ledger-read-account-with-prompt "Account"))
(defun ledger-report--current-month ()
"Return current month as (YEAR . MONTH-INDEX).
MONTH-INDEX ranges from 1 (January) to 12 (December) and YEAR is
a number."
(let* ((time-parts (decode-time))
(year (nth 5 time-parts))
(month-index (nth 4 time-parts)))
(cons year month-index)))
(defun ledger-report--normalize-month (month)
"Return (YEAR . NEW-MONTH) where NEW-MONTH is between 1 and 12.
MONTH is of the form (YEAR . INDEX) where INDEX is an integer.
The purpose of this method is then to convert any year/month pair
to a meaningful date, e.g., from (2018 . -2) to (2017 . 10)."
(let* ((month-index (cdr month))
(year-shift (/ (1- month-index) 12)))
(when (<= month-index 0)
(setq year-shift (1- year-shift)))
(cons (+ (car month) year-shift)
(1+ (mod (1- month-index) 12)))))
(defun ledger-report--shift-month (month shift)
"Return (YEAR . NEW-MONTH) where NEW-MONTH is MONTH+SHIFT.
MONTH is of the form (YEAR . INDEX) where INDEX ranges from
1 (January) to 12 (December) and YEAR is a number."
(let* ((year (car month))
(new-month (+ (cdr month) shift)))
(ledger-report--normalize-month (cons year new-month))))
(defun ledger-report-month-format-specifier ()
"Substitute current month."
(with-current-buffer (or ledger-report-buffer-name (current-buffer))
(let* ((month (or ledger-report-current-month (ledger-report--current-month)))
(year (car month))
(month-index (cdr month)))
(format "%s-%s" year month-index))))
(defun ledger-report-expand-format-specifiers (report-cmd)
"Expand format specifiers in REPORT-CMD with thing under point."
(save-match-data
(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
(let* ((arg (save-match-data
(with-current-buffer ledger-buf
(funcall f))))
(quoted (if (listp arg)
(mapconcat #'identity arg " ")
(shell-quote-argument arg))))
(setq expanded-cmd (replace-match quoted t t expanded-cmd))))))
expanded-cmd)))
(defun ledger-report--cmd-needs-links-p (cmd)
"Check links should be added to the report produced by CMD."
;; --subtotal reports do not produce identifiable transactions, so
;; don't prepend location information for them
(and (string-match "\\<reg\\(ister\\)?\\>" cmd)
ledger-report-links-in-register
(not (string-match "--subtotal" cmd))))
(defun ledger-report--compute-extra-args (report-cmd)
"Compute extra args to add to REPORT-CMD."
`(,@(when (ledger-report--cmd-needs-links-p report-cmd)
'("--prepend-format=%(filename):%(beg_line):"))
,@(when ledger-report-auto-width
`("--columns" ,(format "%d" (- (window-width) 1))))
,@(when ledger-report-use-native-highlighting
'("--color" "--force-color"))
,@(when ledger-report-use-strict
'("--strict"))))
(defun ledger-report-cmd (report-name edit)
"Get the command line to run the report name REPORT-NAME.
Optionally EDIT the command."
(let ((report-cmd (car (cdr (assoc report-name ledger-reports)))))
;; logic for substitution goes here
(when (or (null report-cmd) edit)
(setq report-cmd (ledger-report-read-command report-cmd))
(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 (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)))
report-cmd))
(define-button-type 'ledger-report-register-entry
'follow-link t
'face nil ;; Otherwise make-text-button replaces Ledger's native highlighting
'action (lambda (_button) (ledger-report-visit-source)))
(defun ledger-report--change-month (shift)
"Rebuild report with transactions from current month + SHIFT."
(let* ((current-month (or ledger-report-current-month (ledger-report--current-month)))
(previous-month (ledger-report--shift-month current-month shift)))
(set (make-local-variable 'ledger-report-current-month) previous-month)
(ledger-report-cmd ledger-report-name nil)
(ledger-report-redo)))
(defun ledger-report--add-links ()
"Replace file and line annotations with buttons."
(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 (and file line)
(add-text-properties (line-beginning-position) (line-end-position)
(list 'ledger-source (cons file line)))
(make-text-button
(line-beginning-position) (line-end-position)
'type 'ledger-report-register-entry
'help-echo (format "mouse-2, RET: Visit %s:%d" file line))
;; Appending the face preserves Ledger's native highlighting
(font-lock-append-text-property (line-beginning-position) (line-end-position)
'face 'ledger-font-report-clickable-face)
(end-of-line)))))
(defun ledger-report--compute-header-line (cmd)
"Call `ledger-report-header-line-fn' with `ledger-report-cmd' bound to CMD."
(let ((ledger-report-cmd cmd))
(funcall ledger-report-header-line-fn)))
(defun ledger-do-report (cmd)
"Run a report command line CMD.
CMD may contain a (shell-quoted) version of
`ledger-report--extra-args-marker', which will be replaced by
arguments returned by `ledger-report--compute-extra-args'."
(goto-char (point-min))
(let* ((marker ledger-report--extra-args-marker)
(marker-re (concat " *" (regexp-quote marker)))
(args (ledger-report--compute-extra-args cmd))
(args-str (concat " " (mapconcat #'shell-quote-argument args " ")))
(clean-cmd (replace-regexp-in-string marker-re "" cmd t t))
(real-cmd (replace-regexp-in-string marker-re args-str cmd t t)))
(setq header-line-format
(and ledger-report-use-header-line
`(:eval (ledger-report--compute-header-line ,clean-cmd))))
(unless ledger-report-use-header-line
(insert (format "Report: %s\n" ledger-report-name)
(format "Command: %s\n" clean-cmd)
(make-string (- (window-width) 1) ?=)
"\n\n"))
(let* ((report (shell-command-to-string real-cmd)))
(when ledger-report-use-native-highlighting
(setq report (ansi-color-apply report)))
(save-excursion
(insert report))
(when (ledger-report--cmd-needs-links-p cmd)
(save-excursion
(ledger-report--add-links))))))
(defun ledger-report-visit-source ()
"Visit the transaction under point in the report window."
(interactive)
(let* ((prop (get-text-property (point) 'ledger-source))
(file (car prop))
(line (cdr prop)))
(when (and file line)
(find-file-other-window file)
(widen)
(goto-char (point-min))
(forward-line (1- line))
(ledger-navigate-beginning-of-xact))))
(defun ledger-report-goto ()
"Goto the ledger report buffer."
(interactive)
(let ((rbuf (get-buffer ledger-report-buffer-name)))
(if (not rbuf)
(error "There is no ledger report buffer"))
(pop-to-buffer rbuf)
(ledger-report-maybe-shrink-window)))
(defun ledger-report-redo (&optional _ignore-auto _noconfirm)
"Redo the report in the current ledger report buffer.
IGNORE-AUTO and NOCONFIRM are for compatibility with
`revert-buffer-function' and are currently ignored."
(interactive)
(unless (or (derived-mode-p 'ledger-mode)
(derived-mode-p 'ledger-report-mode))
(user-error "Not in a ledger-mode or ledger-report-mode buffer"))
(let ((cur-buf (current-buffer)))
(when (and ledger-report-auto-refresh
(get-buffer ledger-report-buffer-name))
(pop-to-buffer (get-buffer ledger-report-buffer-name))
(ledger-report-maybe-shrink-window)
(setq ledger-report-cursor-line-number (line-number-at-pos))
(with-silent-modifications
(erase-buffer)
(ledger-do-report ledger-report-cmd)
(when ledger-report-is-reversed
(ledger-report-reverse-lines))
(when ledger-report-auto-refresh-sticky-cursor
(forward-line (- ledger-report-cursor-line-number 5))))
(run-hooks 'ledger-report-after-report-hook)
(pop-to-buffer cur-buf))))
(defun ledger-report-quit ()
"Quit the ledger report buffer."
(interactive)
(ledger-report-goto)
(set-window-configuration ledger-original-window-cfg)
(kill-buffer (get-buffer ledger-report-buffer-name)))
(define-obsolete-function-alias 'ledger-report-kill #'ledger-report-quit)
(defun ledger-report-edit-reports ()
"Edit the defined ledger reports."
(interactive)
(customize-variable 'ledger-reports))
(defun ledger-report-edit-report ()
"Edit the current report command in the mini buffer and re-run the report."
(interactive)
(setq ledger-report-cmd (ledger-report-read-command ledger-report-cmd))
(ledger-report-redo))
(define-obsolete-function-alias 'ledger-report-select-report #'ledger-report "ledger 4.0.0")
(defun ledger-report-read-new-name ()
"Read the name for a new report from the minibuffer."
(let ((name ""))
(while (ledger-report-string-empty-p name)
(setq name (read-from-minibuffer "Report name: " nil nil nil
'ledger-report-name-prompt-history)))
name))
(defun ledger-report-save ()
"Save the current report command line as a named report."
(interactive)
(ledger-report-goto)
(let (existing-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)))))))
(defun ledger-report-previous-month ()
"Rebuild report with transactions from the previous month."
(interactive)
(ledger-report--change-month -1))
(defun ledger-report-next-month ()
"Rebuild report with transactions from the next month."
(interactive)
(ledger-report--change-month 1))
(defun ledger-report-toggle-default-commodity ()
"Add or remove \"--exchange `ledger-reconcile-default-commodity' to the current report."
(interactive)
(unless (derived-mode-p 'ledger-report-mode)
(user-error "Not a ledger report buffer"))
(save-match-data
(if (string-match
(concat (rx (or "--exchange" "-X") (1+ space))
(regexp-quote ledger-reconcile-default-commodity))
ledger-report-cmd)
(setq ledger-report-cmd (replace-match "" nil nil ledger-report-cmd))
(setq ledger-report-cmd (concat ledger-report-cmd
" --exchange " ledger-reconcile-default-commodity))))
(ledger-report-redo))
(provide 'ledger-report)
;;; ledger-report.el ends here

331
lisp/ledger-mode/ledger-schedule.el Normal file
View File

@@ -0,0 +1,331 @@
;;; ledger-schedule.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2013 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:
;;
;; This module provides for automatically adding transactions to a
;; ledger buffer on a periodic basis. Recurrence expressions are
;; inspired by Martin Fowler's "Recurring Events for Calendars",
;; martinfowler.com/apsupp/recurring.pdf
;; use (fset 'VARNAME (macro args)) to put the macro definition in the
;; function slot of the symbol VARNAME. Then use VARNAME as the
;; function without have to use funcall.
(require 'ledger-init)
(require 'cl-lib)
(declare-function ledger-mode "ledger-mode")
;;; Code:
(defgroup ledger-schedule nil
"Support for automatically recommendation transactions."
:group 'ledger)
(defcustom ledger-schedule-buffer-name "*Ledger Schedule*"
"Name for the schedule buffer."
:type 'string
:group 'ledger-schedule)
(defcustom ledger-schedule-look-backward 7
"Number of days to look back in time for transactions."
:type 'integer
:group 'ledger-schedule)
(defcustom ledger-schedule-look-forward 14
"Number of days auto look forward to recommend transactions."
:type 'integer
:group 'ledger-schedule)
(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" 0))
"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 ledger-between (val low high)
"Return TRUE if VAL >= LOW and <= HIGH."
(declare (obsolete <= "Ledger-mode v4.0.1"))
(<= 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 (<= 1 month 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)))
(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 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 (<= -6 count 6) (<= 0 day-of-week 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 (cl-gensym)))
`(let ((,decoded (decode-time date)))
(and (eq (nth 6 ,decoded) ,day-of-week)
(<= ,(* (1- count) 7)
(nth 3 ,decoded)
,(* count 7))))))
((< count 0)
(let ((days-in-month (cl-gensym))
(decoded (cl-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)
(<= (+ ,days-in-month ,(* count 7))
(nth 3 ,decoded)
(+ ,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-OF-WEEK skipping SKIP, starting on START-DATE.
For example every second Friday, regardless of month."
(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 (cl-gensym))
(target-month (cl-gensym))
(target-day (cl-gensym)))
`(let* ((,decoded (decode-time date))
(,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))))))
(defun ledger-schedule-scan-transactions (schedule-file)
"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)
(goto-char (point-min))
(while (re-search-forward "^\\[\\(.*\\)\\] " nil t)
(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)
"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)
"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 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)))
(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, MONTH-DESC, and DAY-DESC are the string portions of the
date descriptor."
(cond
((string-match "[A-Za-z]" day-desc) t) ; there is an advanced day descriptor which overrides the year
((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, MONTH-DESC, and DAY-DESC are the string portions of the
date descriptor."
(cond
((string-match "[A-Za-z]" day-desc) t) ; there is an advanced day descriptor which overrides the month
((string= month-desc "*")
t) ;; always match
((string= month-desc "E") ;; Even
`(cl-evenp (nth 4 (decode-time date))))
((string= month-desc "O") ;; Odd
`(cl-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, MONTH-DESC, and DAY-DESC are the string portions of the
date descriptor."
(cond ((string= day-desc "*")
t)
((string= day-desc "L")
`(= (nth 3 (decode-time date)) (ledger-schedule-days-in-month (nth 4 (decode-time date)) (nth 5 (decode-time date)))))
((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)
(cl-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)
"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)))
(with-current-buffer schedule-buf
(erase-buffer)
(dolist (candidate candidates)
(insert (ledger-format-date (car candidate) ) " " (cadr candidate) "\n"))
(ledger-mode))
(length candidates)))
(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 days in the past to look at
default to `ledger-schedule-look-backward'
LOOK-FORWARD is the number of days in the future 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)
(pop-to-buffer ledger-schedule-buffer-name))
(error "Could not find ledger schedule file at %s" file)))
(provide 'ledger-schedule)
;;; ledger-schedule.el ends here

117
lisp/ledger-mode/ledger-sort.el Normal file
View File

@@ -0,0 +1,117 @@
;;; ledger-sort.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;;
;;; Code:
(require 'ledger-regex)
(require 'ledger-navigate)
(defun ledger-sort-find-start ()
"Find the beginning of a sort region."
(when (re-search-forward ";.*Ledger-mode:.*Start sort" nil t)
(match-end 0)))
(defun ledger-sort-find-end ()
"Find the end of a sort region."
(when (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))
(when (ledger-sort-find-start)
(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))
(when (ledger-sort-find-end)
(delete-region (match-beginning 0) (match-end 0))))
(beginning-of-line)
(insert "\n; Ledger-mode: End sort\n\n"))
(defun ledger-sort-startkey ()
"Return the actual date so the sort subroutine doesn't sort on the entire first line."
(buffer-substring-no-properties (point) (+ 10 (point))))
(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
(let* ((new-beg beg)
(new-end end)
(bounds (ledger-navigate-find-xact-extents (point)))
(point-delta (- (point) (car bounds)))
(target-xact (buffer-substring (car bounds) (cadr bounds)))
(inhibit-modification-hooks t))
(save-excursion
(save-restriction
(goto-char beg)
;; make sure beg of region is at the beginning of a line
(beginning-of-line)
;; make sure point is at the beginning of a 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))))
(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)))
(ledger-sort-region (or sort-start (point-min))
(or sort-end (point-max)))))
(provide 'ledger-sort)
;;; ledger-sort.el ends here

259
lisp/ledger-mode/ledger-state.el Normal file
View File

@@ -0,0 +1,259 @@
;;; ledger-state.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; Utilities for dealing with transaction and posting status.
;;; Code:
(require 'ledger-navigate)
(require 'ledger-context)
(defcustom ledger-clear-whole-transactions nil
"If non-nil, clear whole transactions, not individual postings."
:type 'boolean
:group 'ledger)
(defun ledger-transaction-state ()
"Return the state of the transaction at point."
(save-excursion
(when (or (looking-at "^[0-9]")
(re-search-backward "^[0-9]" nil t))
(skip-chars-forward "0-9./=\\-")
(skip-syntax-forward " ")
(cond ((looking-at "!\\s-*") 'pending)
((looking-at "\\*\\s-*") 'cleared)
(t nil)))))
(defun ledger-posting-state ()
"Return the state of the posting."
(save-excursion
(goto-char (line-beginning-position))
(skip-syntax-forward " ")
(cond ((looking-at "!\\s-*") 'pending)
((looking-at "\\*\\s-*") 'cleared)
(t (ledger-transaction-state)))))
(defun ledger-char-from-state (state)
"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)))
(defun ledger-state-from-string (state-string)
"Get state from STATE-STRING."
(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.
Optional argument STYLE may be `pending' or `cleared', depending
on which type of status the caller wishes to indicate (default is
`cleared'). Returns the new status as 'pending 'cleared or nil.
This function is rather complicated because it must preserve both
the overall formatting of the ledger xact, as well as ensuring
that the most minimal display format is used. This could be
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-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
(goto-char (car bounds)) ;; beginning of xact
(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))))
;;if cur-status if !, or * then delete the marker
(when cur-status
(let ((here (point)))
(skip-chars-forward "*! ")
(let ((width (- (point) here)))
(when (> width 0)
(delete-region here (point))
(if (search-forward " " (line-end-position) t)
(insert (make-string width ? ))))))
(forward-line)
;; 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 (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
(setq inhibit-modification-hooks t)
(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))))
(setq inhibit-modification-hooks nil))
;; This excursion cleans up the xact so that it displays
;; minimally. This means that if all posts are cleared, remove
;; the marks and clear the entire transaction.
(save-excursion
(goto-char (car bounds))
(forward-line)
(let ((first t)
(state nil)
(hetero nil))
(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)))))
(forward-line))
(when (and (not hetero) (not (eq state nil)))
(goto-char (car bounds))
(forward-line)
(while (looking-at "[ \t]")
(skip-chars-forward " \t")
(let ((here (point)))
(skip-chars-forward "*! ")
(let ((width (- (point) here)))
(when (> width 0)
(delete-region here (point))
(if (re-search-forward "\\(\t\\| [ \t]\\)"
(line-end-position) t)
(insert (make-string width ? ))))))
(forward-line))
(goto-char (car bounds))
(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)
(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)))))))
new-status))
(defun ledger-toggle-current (&optional style)
"Toggle the current thing at point with optional STYLE."
(interactive)
(if (or ledger-clear-whole-transactions
(eq 'transaction (ledger-thing-at-point)))
(progn
(save-excursion
(forward-line)
(goto-char (line-beginning-position))
(while (and (not (eolp))
(save-excursion
(not (eq 'transaction (ledger-thing-at-point)))))
(if (looking-at "\\s-+[*!]")
(ledger-toggle-current-posting style))
(forward-line)
(goto-char (line-beginning-position))))
(ledger-toggle-current-transaction 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))
(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))))))
(provide 'ledger-state)
;;; ledger-state.el ends here

137
lisp/ledger-mode/ledger-test.el Normal file
View File

@@ -0,0 +1,137 @@
;;; ledger-test.el --- Helper code for use with the "ledger" command-line tool
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;;; Code:
(declare-function ledger-mode "ledger-mode") ; TODO: fix this cyclic dependency
(require 'org)
(require 'outline)
(defgroup ledger-test nil
"Definitions for the Ledger testing framework"
:group 'ledger)
(defcustom ledger-source-directory "~/ledger/"
"Directory where the Ledger sources are located."
:type 'directory
:group 'ledger-test)
(defcustom ledger-test-binary "/Products/ledger/debug/ledger"
"Directory where the Ledger debug binary is located."
:type 'file
:group 'ledger-test)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ledger-create-test ()
"Create a regression test."
(interactive)
(save-restriction
(org-narrow-to-subtree)
(save-excursion
(let (text beg)
(goto-char (point-min))
(forward-line 1)
(setq beg (point))
(search-forward ":PROPERTIES:")
(goto-char (line-beginning-position))
(setq text (buffer-substring-no-properties beg (point)))
(goto-char (point-min))
(re-search-forward ":ID:\\s-+\\([^-]+\\)")
(find-file-other-window
(format "~/src/ledger/test/regress/%s.test" (match-string 1)))
(sit-for 0)
(insert text)
(goto-char (point-min))
(while (not (eobp))
(goto-char (line-beginning-position))
(delete-char 3)
(forward-line 1))))))
(defun ledger-test-org-narrow-to-entry ()
(outline-back-to-heading)
(narrow-to-region (point) (progn (outline-next-heading) (point)))
(goto-char (point-min)))
(defun ledger-test-create ()
(interactive)
(let ((uuid (org-entry-get (point) "ID")))
(when (string-match "\\`\\([^-]+\\)-" uuid)
(let ((prefix (match-string 1 uuid))
input output)
(save-restriction
(ledger-test-org-narrow-to-entry)
(goto-char (point-min))
(while (re-search-forward "#\\+begin_src ledger" nil t)
(goto-char (match-end 0))
(forward-line 1)
(let ((beg (point)))
(re-search-forward "#\\+end_src")
(setq input
(concat (or input "")
(buffer-substring beg (match-beginning 0))))))
(goto-char (point-min))
(while (re-search-forward ":OUTPUT:" nil t)
(goto-char (match-end 0))
(forward-line 1)
(let ((beg (point)))
(re-search-forward ":END:")
(setq output
(concat (or output "")
(buffer-substring beg (match-beginning 0)))))))
(find-file-other-window
(expand-file-name (concat prefix ".test")
(expand-file-name "test/regress"
ledger-source-directory)))
(ledger-mode)
(if input
(insert input)
(insert "2012-03-17 Payee\n")
(insert " Expenses:Food $20\n")
(insert " Assets:Cash\n"))
(insert "\ntest reg\n")
(if output
(insert output))
(insert "end test\n")))))
(defun ledger-test-run ()
(interactive)
(save-excursion
(goto-char (point-min))
(when (re-search-forward "^test \\(.+?\\)\\( ->.*\\)?$" nil t)
(let ((command (expand-file-name ledger-test-binary))
(args (format "--args-only --columns=80 --no-color -f \"%s\" %s"
buffer-file-name (match-string 1))))
(setq args (replace-regexp-in-string "\\$sourcepath"
ledger-source-directory args))
(kill-new args)
(message "Testing: ledger %s" args)
(let ((prev-directory default-directory))
(cd ledger-source-directory)
(unwind-protect
(async-shell-command (format "\"%s\" %s" command args))
(cd prev-directory)))))))
(provide 'ledger-test)
;;; ledger-test.el ends here

179
lisp/ledger-mode/ledger-texi.el Normal file
View File

@@ -0,0 +1,179 @@
;;; ledger-texi.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;;
;;; Code:
(defvar ledger-binary-path)
(defgroup ledger-texi nil
"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)
(defcustom ledger-texi-normalization-args "--args-only --columns 80"
"Texi normalization for producing ledger output."
:type 'string
:group 'ledger-texi)
(defun ledger-update-test ()
(interactive)
(goto-char (point-min))
(let ((command (buffer-substring (point-min) (line-end-position))))
(re-search-forward "^<<<\n")
(let ((beg (point)) end)
(re-search-forward "^>>>")
(setq end (match-beginning 0))
(forward-line 1)
(let ((output-beg (point)))
(re-search-forward "^>>>")
(goto-char (match-beginning 0))
(delete-region output-beg (point))
(apply #'call-process-region
beg end (expand-file-name "~/Products/ledger/debug/ledger")
nil t nil
"-f" "-" "--args-only" "--columns=80" "--no-color"
(split-string command " "))))))
(defun ledger-texi-write-test (name command input output &optional category)
(let ((buf (current-buffer)))
(with-current-buffer (find-file-noselect
(expand-file-name (concat name ".test") category))
(erase-buffer)
(let ((case-fold-search nil))
(if (string-match "\\$LEDGER\\s-+" command)
(setq command (replace-match "" t t command)))
(if (string-match " -f \\$\\([-a-z]+\\)" command)
(setq command (replace-match "" t t command))))
(insert command ?\n)
(insert "<<<" ?\n)
(insert input)
(insert ">>>1" ?\n)
(insert output)
(insert ">>>2" ?\n)
(insert "=== 0" ?\n)
(save-buffer)
(unless (eq buf (current-buffer))
(kill-buffer (current-buffer))))))
(defun ledger-texi-update-test ()
(interactive)
(let ((details (ledger-texi-test-details))
(name (file-name-sans-extension
(file-name-nondirectory (buffer-file-name)))))
(ledger-texi-write-test
name (nth 0 details)
(nth 1 details)
(ledger-texi-invoke-command
(ledger-texi-expand-command
(nth 0 details)
(ledger-texi-write-test-data name (nth 1 details)))))))
(defun ledger-texi-test-details ()
(goto-char (point-min))
(let ((command (buffer-substring (point) (line-end-position)))
input output)
(re-search-forward "^<<<")
(let ((input-beg (1+ (match-end 0))))
(re-search-forward "^>>>1")
(let ((output-beg (1+ (match-end 0))))
(setq input (buffer-substring input-beg (match-beginning 0)))
(re-search-forward "^>>>2")
(setq output (buffer-substring output-beg (match-beginning 0)))
(list command input output)))))
(defun ledger-texi-expand-command (command data-file)
(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)))
(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))))
(defun ledger-texi-write-test-data (name input)
(let ((path (expand-file-name name temporary-file-directory)))
(with-current-buffer (find-file-noselect path)
(erase-buffer)
(insert input)
(save-buffer))
path))
(defun ledger-texi-update-examples ()
(interactive)
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^@c \\(\\(?:sm\\)?ex\\) \\(\\S-+\\): \\(.*\\)" nil t)
(let ((section (match-string 1))
(example-name (match-string 2))
(command (match-string 3))
(data-file ledger-texi-sample-doc-path)
input output)
(goto-char (match-end 0))
(forward-line)
(when (looking-at "@\\(\\(?:small\\)?example\\)")
(let ((beg (point)))
(re-search-forward "^@end \\(\\(?:small\\)?example\\)")
(delete-region beg (1+ (point)))))
(when (let ((case-fold-search nil))
(string-match " -f \\$\\([-a-z]+\\)" command))
(let ((label (match-string 1 command)))
(setq command (replace-match "" t t command))
(save-excursion
(goto-char (point-min))
(search-forward (format "@c data: %s" label))
(re-search-forward "@\\(\\(?:small\\)?example\\)")
(forward-line)
(let ((beg (point)))
(re-search-forward "@end \\(\\(?:small\\)?example\\)")
(setq data-file (ledger-texi-write-test-data
(format "%s.dat" label)
(buffer-substring-no-properties
beg (match-beginning 0))))))))
(let ((section-name (if (string= section "smex")
"smallexample"
"example"))
(output (ledger-texi-invoke-command
(ledger-texi-expand-command command data-file))))
(insert "@" section-name ?\n output
"@end " section-name ?\n))
;; Update the regression test associated with this example
(ledger-texi-write-test example-name command input output
"../test/manual")))))
(provide 'ledger-texi)
;;; ledger-texi.el ends here

227
lisp/ledger-mode/ledger-xact.el Normal file
View File

@@ -0,0 +1,227 @@
;;; ledger-xact.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.
;;; Commentary:
;; Utilities for running ledger synchronously.
;;; Code:
(require 'eshell)
(require 'ledger-regex)
(require 'ledger-navigate)
(require 'ledger-exec)
(require 'ledger-post)
(declare-function ledger-read-date "ledger-mode" (prompt))
(declare-function ledger-format-date "ledger-init" (&optional date))
;; 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
:group 'ledger)
(defvar-local ledger-xact-highlight-overlay (list))
(defun ledger-highlight-make-overlay ()
(let ((ovl (make-overlay 1 1)))
(overlay-put ovl 'font-lock-face 'ledger-font-xact-highlight-face)
(overlay-put ovl 'priority '(nil . 99))
ovl))
(defun ledger-highlight-xact-under-point ()
"Move the highlight overlay to the current transaction."
(when ledger-highlight-xact-under-point
(unless ledger-xact-highlight-overlay
(setq ledger-xact-highlight-overlay (ledger-highlight-make-overlay)))
(let ((exts (ledger-navigate-find-element-extents (point))))
(let ((b (car exts))
(e (cadr exts))
(p (point)))
(if (and (> (- e b) 1) ; not an empty line
(<= p e) (>= p b) ; point is within the boundaries
(not (region-active-p))) ; no active region
(move-overlay ledger-xact-highlight-overlay b (+ 1 e))
(move-overlay ledger-xact-highlight-overlay 1 1))))))
(defun ledger-xact-context ()
"Return the context of the transaction containing point or nil."
(let ((i 0))
(while (eq (ledger-context-line-type (ledger-context-other-line i)) 'acct-transaction)
(setq i (- i 1)))
(let ((context-info (ledger-context-other-line i)))
(if (eq (ledger-context-line-type context-info) 'xact)
context-info
nil))))
(defun ledger-xact-payee ()
"Return the payee of the transaction containing point or nil."
(let ((xact-context (ledger-xact-context)))
(if xact-context
(ledger-context-field-value xact-context 'payee)
nil)))
(defun ledger-xact-date ()
"Return the date of the transaction containing point or nil."
(let ((xact-context (ledger-xact-context)))
(if xact-context
(ledger-context-field-value xact-context 'date)
nil)))
(defun ledger-time-less-p (t1 t2)
"Say whether time value T1 is less than time value T2."
;; TODO: assert listp, or support when both are strings
(or (< (car t1) (car t2))
(and (= (car t1) (car t2))
(< (nth 1 t1) (nth 1 t2)))))
(defun ledger-xact-find-slot (moment)
"Find the right place in the buffer for a transaction at MOMENT.
MOMENT is an encoded date"
(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)
(insert "\n")
(forward-line)))))
(defun ledger-xact-iterate-transactions (callback)
"Iterate through each transaction call CALLBACK for each."
(goto-char (point-min))
(let* ((now (current-time))
(current-year (nth 5 (decode-time now))))
(while (not (eobp))
(when (looking-at ledger-iterate-regex)
(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))
(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))))
(defvar ledger-copy-transaction-insert-blank-line-after nil
"Non-nil means insert blank line after a transaction inserted with ‘ledger-copy-transaction-at-point’.")
(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
(ledger-read-date "Copy to date: ")))
(let* ((extents (ledger-navigate-find-xact-extents (point)))
(transaction (buffer-substring-no-properties (car extents) (cadr extents)))
(encoded-date (ledger-parse-iso-date date)))
(ledger-xact-find-slot encoded-date)
(insert transaction
(if ledger-copy-transaction-insert-blank-line-after
"\n\n"
"\n"))
(beginning-of-line -1)
(ledger-navigate-beginning-of-xact)
(re-search-forward ledger-iso-date-regexp)
(replace-match date)
(ledger-next-amount)
(if (re-search-forward "[-0-9]")
(goto-char (match-beginning 0)))))
(defun ledger-delete-current-transaction (pos)
"Delete the transaction surrounging POS."
(interactive "d")
(let ((bounds (ledger-navigate-find-xact-extents pos)))
(delete-region (car bounds) (cadr bounds)))
(delete-blank-lines))
(defvar ledger-add-transaction-last-date nil
"Last date entered using `ledger-read-transaction'.")
(defun ledger-read-transaction ()
"Read the text of a transaction, which is at least the current date."
(let* ((reference-date (or ledger-add-transaction-last-date (current-time)))
(full-date-string (ledger-format-date reference-date))
;; Pre-fill year and month, but not day: this assumes DD is the last format arg.
(initial-string (replace-regexp-in-string "[0-9]+$" "" full-date-string))
(entered-string (ledger-read-date "Date: ")))
(if (string= initial-string entered-string)
full-date-string
entered-string)))
(defun ledger-parse-iso-date (date)
"Try to parse DATE using `ledger-iso-date-regexp' and return a time value or nil."
(save-match-data
(when (string-match ledger-iso-date-regexp 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))))))
(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
correct chronological place in the buffer. Interactively, the
date is requested via `ledger-read-date'."
(interactive (list (ledger-read-transaction)))
(let* ((args (with-temp-buffer
(insert transaction-text)
(eshell-parse-arguments (point-min) (point-max))))
(ledger-buf (current-buffer))
(separator "\n"))
(unless insert-at-point
(let* ((date (car args))
(parsed-date (ledger-parse-iso-date date)))
(setq ledger-add-transaction-last-date parsed-date)
(push-mark)
;; TODO: what about when it can't be parsed?
(ledger-xact-find-slot (or parsed-date date))
(when (looking-at "\n*\\'")
(setq separator ""))))
(if (> (length args) 1)
(save-excursion
(insert
(with-temp-buffer
(apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact"
(mapcar 'eval args))
(goto-char (point-min))
(ledger-post-align-postings (point-min) (point-max))
(buffer-string))
separator))
(progn
(insert (car args) " ")
(save-excursion (insert "\n" separator))))))
(provide 'ledger-xact)
;;; ledger-xact.el ends here