ledger-xact.el (8876B)
1 ;;; ledger-xact.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org) 4 5 ;; This file is not part of GNU Emacs. 6 7 ;; This is free software; you can redistribute it and/or modify it under 8 ;; the terms of the GNU General Public License as published by the Free 9 ;; Software Foundation; either version 2, or (at your option) any later 10 ;; version. 11 ;; 12 ;; This is distributed in the hope that it will be useful, but WITHOUT 13 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or 14 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15 ;; for more details. 16 ;; 17 ;; You should have received a copy of the GNU General Public License 18 ;; along with GNU Emacs; see the file COPYING. If not, write to the 19 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, 20 ;; MA 02110-1301 USA. 21 22 23 ;;; Commentary: 24 ;; Utilities for running ledger synchronously. 25 26 ;;; Code: 27 28 (require 'eshell) 29 (require 'ledger-regex) 30 (require 'ledger-navigate) 31 (require 'ledger-exec) 32 (require 'ledger-post) 33 (declare-function ledger-read-date "ledger-mode" (prompt)) 34 35 ;; TODO: This file depends on code in ledger-mode.el, which depends on this. 36 37 (defcustom ledger-highlight-xact-under-point t 38 "If t highlight xact under point." 39 :type 'boolean 40 :group 'ledger) 41 42 (defcustom ledger-add-transaction-prompt-for-text t 43 "When non-nil, use ledger xact to format transaction. 44 When nil, `ledger-add-transaction' will not prompt twice." 45 :type 'boolean 46 :package-version '(ledger-mode . "4.0.1") 47 :group 'ledger) 48 49 (defvar-local ledger-xact-highlight-overlay (list)) 50 51 (defun ledger-highlight-make-overlay () 52 (let ((ovl (make-overlay 1 1))) 53 (overlay-put ovl 'font-lock-face 'ledger-font-xact-highlight-face) 54 (overlay-put ovl 'priority '(nil . 99)) 55 ovl)) 56 57 (defun ledger-highlight-xact-under-point () 58 "Move the highlight overlay to the current transaction." 59 (when ledger-highlight-xact-under-point 60 (unless ledger-xact-highlight-overlay 61 (setq ledger-xact-highlight-overlay (ledger-highlight-make-overlay))) 62 (let ((exts (ledger-navigate-find-element-extents (point)))) 63 (let ((b (car exts)) 64 (e (cadr exts)) 65 (p (point))) 66 (if (and (> (- e b) 1) ; not an empty line 67 (<= p e) (>= p b) ; point is within the boundaries 68 (not (region-active-p))) ; no active region 69 (move-overlay ledger-xact-highlight-overlay b (+ 1 e)) 70 (move-overlay ledger-xact-highlight-overlay 1 1)))))) 71 72 (defun ledger-xact-context () 73 "Return the context of the transaction containing point or nil." 74 (let ((i 0)) 75 (while (eq (ledger-context-line-type (ledger-context-other-line i)) 'acct-transaction) 76 (setq i (- i 1))) 77 (let ((context-info (ledger-context-other-line i))) 78 (when (eq (ledger-context-line-type context-info) 'xact) 79 context-info)))) 80 81 (defun ledger-xact-payee () 82 "Return the payee of the transaction containing point or nil." 83 (when-let ((xact-context (ledger-xact-context))) 84 (ledger-context-field-value xact-context 'payee))) 85 86 (defun ledger-xact-date () 87 "Return the date of the transaction containing point or nil." 88 (when-let ((xact-context (ledger-xact-context))) 89 (ledger-context-field-value xact-context 'date))) 90 91 (defun ledger-xact-find-slot (moment) 92 "Find the right place in the buffer for a transaction at MOMENT. 93 MOMENT is an encoded date" 94 (let (last-xact-start) 95 (catch 'found 96 (ledger-xact-iterate-transactions 97 (lambda (start date _mark _desc) 98 (setq last-xact-start start) 99 (when (time-less-p moment date) 100 (throw 'found t))))) 101 ;; If we are inserting at the end of the buffer, insert an extra newline 102 (when (and (eobp) last-xact-start) 103 (let ((end (cadr (ledger-navigate-find-xact-extents last-xact-start)))) 104 (goto-char end) 105 (insert "\n") 106 (forward-line))))) 107 108 (defun ledger-xact-iterate-transactions (callback) 109 "Iterate through each transaction call CALLBACK for each." 110 (goto-char (point-min)) 111 (let* ((now (current-time)) 112 (current-year (nth 5 (decode-time now)))) 113 (while (not (eobp)) 114 (when (looking-at ledger-iterate-regexp) 115 (if-let ((year (match-string 1))) 116 (setq current-year (string-to-number year)) ;a Y directive was found 117 (let ((start (match-beginning 0)) 118 (year (match-string (+ ledger-regex-iterate-group-actual-date 1))) 119 (month (string-to-number (match-string (+ ledger-regex-iterate-group-actual-date 2)))) 120 (day (string-to-number (match-string (+ ledger-regex-iterate-group-actual-date 3)))) 121 (state (match-string ledger-regex-iterate-group-state)) 122 (payee (match-string ledger-regex-iterate-group-payee))) 123 (if (and year (> (length year) 0)) 124 (setq year (string-to-number year))) 125 (funcall callback start 126 (encode-time 0 0 0 day month 127 (or year current-year)) 128 state payee)))) 129 (forward-line)))) 130 131 (defcustom ledger-copy-transaction-insert-blank-line-after nil 132 "When non-nil, insert a blank line after `ledger-copy-transaction-at-point'." 133 :type 'boolean 134 :group 'ledger) 135 136 (defun ledger-copy-transaction-at-point (date) 137 "Ask for a new DATE and copy the transaction under point to that date. 138 Leave point on the first amount." 139 (interactive (list (ledger-read-date "Copy to date: "))) 140 (let* ((extents (ledger-navigate-find-xact-extents (point))) 141 (transaction (buffer-substring-no-properties (car extents) (cadr extents))) 142 (encoded-date (ledger-parse-iso-date date))) 143 (push-mark) 144 (ledger-xact-find-slot encoded-date) 145 (insert transaction 146 (if (and ledger-copy-transaction-insert-blank-line-after (not (eobp))) 147 "\n\n" 148 "\n")) 149 (beginning-of-line -1) 150 (ledger-navigate-beginning-of-xact) 151 (re-search-forward ledger-iso-date-regexp) 152 (replace-match date) 153 (ledger-next-amount) 154 (if (re-search-forward "[-0-9]") 155 (goto-char (match-beginning 0))))) 156 157 (defun ledger-delete-current-transaction (pos) 158 "Delete the transaction surrounding POS." 159 (interactive "d") 160 (let ((bounds (ledger-navigate-find-xact-extents pos))) 161 (delete-region (car bounds) (cadr bounds))) 162 (delete-blank-lines)) 163 164 (defvar ledger-add-transaction-last-date nil 165 "Last date entered using `ledger-read-transaction'.") 166 167 (defun ledger-read-transaction () 168 "Read the text of a transaction, which is at least the current date." 169 (let ((date (ledger-read-date "Date: "))) 170 (concat date " " 171 (when ledger-add-transaction-prompt-for-text 172 (read-string (concat "xact " date ": ") nil 'ledger-minibuffer-history))))) 173 174 (defun ledger-parse-iso-date (date) 175 "Try to parse DATE using `ledger-iso-date-regexp' and return a time value or nil." 176 (save-match-data 177 (when (string-match ledger-iso-date-regexp date) 178 (encode-time 0 0 0 (string-to-number (match-string 4 date)) 179 (string-to-number (match-string 3 date)) 180 (string-to-number (match-string 2 date)))))) 181 182 (defun ledger-add-transaction (transaction-text &optional insert-at-point) 183 "Use ledger xact TRANSACTION-TEXT to add a transaction to the buffer. 184 If INSERT-AT-POINT is non-nil insert the transaction there, 185 otherwise call `ledger-xact-find-slot' to insert it at the 186 correct chronological place in the buffer. 187 188 Interactively, the date is requested via `ledger-read-date' and 189 the \\[universal-argument] enables INSERT-AT-POINT." 190 (interactive (list (ledger-read-transaction) current-prefix-arg)) 191 (let* ((args (with-temp-buffer 192 (insert transaction-text) 193 (eshell-parse-arguments (point-min) (point-max)))) 194 (ledger-buf (current-buffer)) 195 (separator "\n")) 196 (unless insert-at-point 197 (let* ((date (car args)) 198 (parsed-date (ledger-parse-iso-date date))) 199 (setq ledger-add-transaction-last-date parsed-date) 200 (push-mark) 201 ;; TODO: what about when it can't be parsed? 202 (ledger-xact-find-slot (or parsed-date date)) 203 (when (looking-at "\n*\\'") 204 (setq separator "")))) 205 (if (cdr args) 206 (save-excursion 207 (insert 208 (with-temp-buffer 209 (apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact" 210 (mapcar 'eval args)) 211 (goto-char (point-min)) 212 (ledger-post-align-postings (point-min) (point-max)) 213 (buffer-string)) 214 separator)) 215 (insert (car args) " ") 216 (save-excursion (insert "\n" separator))))) 217 218 (provide 'ledger-xact) 219 220 ;;; ledger-xact.el ends here