ledger-state.el (9791B)
1 ;;; ledger-state.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 dealing with transaction and posting status. 25 26 ;;; Code: 27 (require 'ledger-navigate) 28 (require 'ledger-context) 29 30 (defcustom ledger-clear-whole-transactions nil 31 "If non-nil, clear whole transactions, not individual postings." 32 :type 'boolean 33 :group 'ledger) 34 35 (defun ledger-transaction-state () 36 "Return the state of the transaction at point." 37 (save-excursion 38 (when (or (looking-at "^[0-9]") 39 (re-search-backward "^[0-9]" nil t)) 40 (skip-chars-forward "0-9./=\\-") 41 (skip-syntax-forward " ") 42 (cond ((looking-at "!\\s-*") 'pending) 43 ((looking-at "\\*\\s-*") 'cleared) 44 (t nil))))) 45 46 (defun ledger-posting-state () 47 "Return the state of the posting." 48 (save-excursion 49 (goto-char (line-beginning-position)) 50 (skip-syntax-forward " ") 51 (cond ((looking-at "!\\s-*") 'pending) 52 ((looking-at "\\*\\s-*") 'cleared) 53 (t (ledger-transaction-state))))) 54 55 (defun ledger-char-from-state (state) 56 "Return the char representation of STATE." 57 (if state 58 (if (eq state 'pending) 59 "!" 60 "*") 61 "")) 62 63 (defun ledger-state-from-char (state-char) 64 "Get state from STATE-CHAR." 65 (cond ((eql state-char ?\!) 'pending) 66 ((eql state-char ?\*) 'cleared) 67 ((eql state-char ?\;) 'comment) 68 (t nil))) 69 70 71 (defun ledger-state-from-string (state-string) 72 "Get state from STATE-STRING." 73 (when state-string 74 (cond 75 ((string-match "!" state-string) 'pending) 76 ((string-match "\\*" state-string) 'cleared) 77 ((string-match ";" state-string) 'comment) 78 (t nil)))) 79 80 (defun ledger-toggle-current-posting (&optional style) 81 "Toggle the cleared status of the transaction under point. 82 Optional argument STYLE may be `pending' or `cleared', depending 83 on which type of status the caller wishes to indicate (default is 84 `cleared'). Returns the new status as `pending' `cleared' or nil. 85 This function is rather complicated because it must preserve both 86 the overall formatting of the ledger xact, as well as ensuring 87 that the most minimal display format is used. This could be 88 achieved more certainly by passing the xact to ledger for 89 formatting, but doing so causes inline math expressions to be 90 dropped." 91 (interactive) 92 (let ((bounds (ledger-navigate-find-xact-extents (point))) 93 new-status cur-status) 94 ;; Uncompact the xact, to make it easier to toggle the 95 ;; transaction 96 (save-excursion ;; this excursion checks state of entire 97 ;; transaction and unclears if marked 98 (goto-char (car bounds)) ;; beginning of xact 99 (skip-chars-forward "0-9./=\\-") ;; skip the date 100 (skip-chars-forward " \t") ;; skip the white space after the date 101 (setq cur-status (and (member (char-after) '(?\* ?\!)) 102 (ledger-state-from-char (char-after)))) 103 ;;if cur-status if !, or * then delete the marker 104 (when cur-status 105 (let ((here (point))) 106 (skip-chars-forward "*! ") 107 (let ((width (- (point) here))) 108 (when (> width 0) 109 (delete-region here (point)) 110 (if (search-forward " " (line-end-position) t) 111 (insert (make-string width ? )))))) 112 (forward-line) 113 ;; Shift the cleared/pending status to the postings 114 (while (looking-at "[ \t]") 115 (skip-chars-forward " \t") 116 (when (not (eq (ledger-state-from-char (char-after)) 'comment)) 117 (insert (ledger-char-from-state cur-status) " ") 118 (if (and (search-forward " " (line-end-position) t) 119 (looking-at " ")) 120 (delete-char 2))) 121 (forward-line)) 122 (setq new-status nil))) 123 124 ;;this excursion toggles the posting status 125 (save-excursion 126 (setq inhibit-modification-hooks t) 127 128 (goto-char (line-beginning-position)) 129 (when (looking-at "[ \t]") 130 (skip-chars-forward " \t") 131 (let ((here (point)) 132 (cur-status (ledger-state-from-char (char-after)))) 133 (skip-chars-forward "*! ") 134 (let ((width (- (point) here))) 135 (when (> width 0) 136 (delete-region here (point)) 137 (save-excursion 138 (if (search-forward " " (line-end-position) t) 139 (insert (make-string width ? )))))) 140 (let (inserted) 141 (if cur-status 142 (if (and style (eq style 'cleared)) 143 (progn 144 (insert "* ") 145 (setq inserted 'cleared))) 146 (if (and style (eq style 'pending)) 147 (progn 148 (insert "! ") 149 (setq inserted 'pending)) 150 (progn 151 (insert "* ") 152 (setq inserted 'cleared)))) 153 (if (and inserted 154 (re-search-forward "\\(\t\\| [ \t]\\)" 155 (line-end-position) t)) 156 (cond 157 ((looking-at "\t") 158 (delete-char 1)) 159 ((looking-at " [ \t]") 160 (delete-char 2)) 161 ((looking-at " ") 162 (delete-char 1)))) 163 (setq new-status inserted)))) 164 (setq inhibit-modification-hooks nil)) 165 166 ;; This excursion cleans up the xact so that it displays 167 ;; minimally. This means that if all posts are cleared, remove 168 ;; the marks and clear the entire transaction. 169 (save-excursion 170 (goto-char (car bounds)) 171 (forward-line) 172 (let ((first t) 173 (state nil) 174 (hetero nil)) 175 (while (and (not hetero) (looking-at "[ \t]")) 176 (skip-chars-forward " \t") 177 (let ((cur-status (ledger-state-from-char (char-after)))) 178 (if (not (eq cur-status 'comment)) 179 (if first 180 (setq state cur-status 181 first nil) 182 (if (not (eq state cur-status)) 183 (setq hetero t))))) 184 (forward-line)) 185 (when (and (not hetero) (not (eq state nil))) 186 (goto-char (car bounds)) 187 (forward-line) 188 (while (looking-at "[ \t]") 189 (skip-chars-forward " \t") 190 (let ((here (point))) 191 (skip-chars-forward "*! ") 192 (let ((width (- (point) here))) 193 (when (> width 0) 194 (delete-region here (point)) 195 (if (re-search-forward "\\(\t\\| [ \t]\\)" 196 (line-end-position) t) 197 (insert (make-string width ? )))))) 198 (forward-line)) 199 (goto-char (car bounds)) 200 (skip-chars-forward "0-9./=\\-") ;; Skip the date 201 (skip-chars-forward " \t") ;; Skip the white space 202 (insert (ledger-char-from-state state) " ") 203 (setq new-status state) 204 (if (re-search-forward "\\(\t\\| [ \t]\\)" 205 (line-end-position) t) 206 (cond 207 ((looking-at "\t") 208 (delete-char 1)) 209 ((looking-at " [ \t]") 210 (delete-char 2)) 211 ((looking-at " ") 212 (delete-char 1))))))) 213 new-status)) 214 215 (defun ledger-toggle-current (&optional style) 216 "Toggle the current thing at point with optional STYLE." 217 (interactive) 218 (let ((thing (ledger-thing-at-point))) 219 (if (or (and ledger-clear-whole-transactions (eq 'posting thing)) 220 (eq 'transaction thing)) 221 (let ((end (save-excursion (ledger-navigate-end-of-xact) (point-marker)))) 222 ;; clear state markings on postings 223 (save-excursion 224 (forward-line) 225 (beginning-of-line) 226 (while (< (point) end) 227 (when (looking-at "\\s-+[*!]") 228 (ledger-toggle-current-posting style)) 229 (forward-line))) 230 (set-marker end nil) 231 (ledger-toggle-current-transaction style)) 232 (ledger-toggle-current-posting style)))) 233 234 (defun ledger-toggle-current-transaction (&optional style) 235 "Toggle the transaction at point using optional STYLE." 236 (interactive) 237 (save-excursion 238 (when (or (looking-at "^[0-9]") 239 (re-search-backward "^[0-9]" nil t)) 240 (skip-chars-forward "0-9./=\\-") 241 (delete-horizontal-space) 242 (if (or (eq (ledger-state-from-char (char-after)) 'pending) 243 (eq (ledger-state-from-char (char-after)) 'cleared)) 244 (progn 245 (delete-char 1) 246 (when (and style (eq style 'cleared)) 247 (insert " *") 248 'cleared)) 249 (if (and style (eq style 'pending)) 250 (progn 251 (insert " ! ") 252 'pending) 253 (progn 254 (insert " * ") 255 'cleared)))))) 256 257 (provide 'ledger-state) 258 259 ;;; ledger-state.el ends here