ledger-schedule.el (14849B)
1 ;;; ledger-schedule.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2013 Craig Earls (enderw88 at gmail dot com) 4 5 ;; This file is not part of GNU Emacs. 6 7 ;; This is free software; you can redistribute it and/or modify it 8 ;; under the terms of the GNU General Public License as published by 9 ;; the Free Software Foundation; either version 2, or (at your option) 10 ;; any later 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 14 ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public 15 ;; License 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 ;;; Commentary: 23 ;; 24 ;; This module provides for automatically adding transactions to a 25 ;; ledger buffer on a periodic basis. Recurrence expressions are 26 ;; inspired by Martin Fowler's "Recurring Events for Calendars", 27 ;; martinfowler.com/apsupp/recurring.pdf 28 29 ;; use (fset 'VARNAME (macro args)) to put the macro definition in the 30 ;; function slot of the symbol VARNAME. Then use VARNAME as the 31 ;; function without have to use funcall. 32 33 34 (require 'ledger-init) 35 (require 'cl-lib) 36 37 (declare-function ledger-mode "ledger-mode") 38 ;;; Code: 39 40 (defgroup ledger-schedule nil 41 "Support for automatically recommendation transactions." 42 :group 'ledger) 43 44 (defcustom ledger-schedule-buffer-name "*Ledger Schedule*" 45 "Name for the schedule buffer." 46 :type 'string 47 :group 'ledger-schedule) 48 49 (defcustom ledger-schedule-look-backward 7 50 "Number of days to look back in time for transactions." 51 :type 'integer 52 :group 'ledger-schedule) 53 54 (defcustom ledger-schedule-look-forward 14 55 "Number of days auto look forward to recommend transactions." 56 :type 'integer 57 :group 'ledger-schedule) 58 59 (defcustom ledger-schedule-file "~/ledger-schedule.ledger" 60 "File to find scheduled transactions." 61 :type 'file 62 :group 'ledger-schedule) 63 64 (defcustom ledger-schedule-week-days '(("Mo" 1) 65 ("Tu" 2) 66 ("We" 3) 67 ("Th" 4) 68 ("Fr" 5) 69 ("Sa" 6) 70 ("Su" 0)) 71 "List of weekday abbreviations. 72 There must be exactly seven entries each with a two character 73 abbreviation for a day and the number of that day in the week." 74 :type '(alist :key-type string :value-type (group integer)) 75 :group 'ledger-schedule) 76 77 (defsubst ledger-between (val low high) 78 "Return TRUE if VAL >= LOW and <= HIGH." 79 (declare (obsolete <= "Ledger-mode v4.0.1")) 80 (<= low val high)) 81 82 (defun ledger-schedule-days-in-month (month year) 83 "Return number of days in the MONTH, MONTH is from 1 to 12. 84 If YEAR is nil, assume it is not a leap year" 85 (if (<= 1 month 12) 86 (if (and year (date-leap-year-p year) (= 2 month)) 87 29 88 (nth (1- month) '(31 28 31 30 31 30 31 31 30 31 30 31))) 89 (error "Month out of range, MONTH=%S" month))) 90 91 (defun ledger-schedule-encode-day-of-week (day-string) 92 "Return the numerical day of week corresponding to DAY-STRING." 93 (cadr (assoc day-string ledger-schedule-week-days))) 94 95 ;; Macros to handle date expressions 96 97 (defun ledger-schedule-constrain-day-in-month (count day-of-week) 98 "Return a form that returns TRUE for the the COUNT DAY-OF-WEEK. 99 For example, return true if date is the 3rd Thursday of the 100 month. Negative COUNT starts from the end of the month. (EQ 101 COUNT 0) means EVERY day-of-week (eg. every Saturday)" 102 (if (and (<= -6 count 6) (<= 0 day-of-week 6)) 103 (cond ((zerop count) ;; Return true if day-of-week matches 104 `(eq (nth 6 (decode-time date)) ,day-of-week)) 105 ((> count 0) ;; Positive count 106 (let ((decoded (cl-gensym))) 107 `(let ((,decoded (decode-time date))) 108 (and (eq (nth 6 ,decoded) ,day-of-week) 109 (<= ,(* (1- count) 7) 110 (nth 3 ,decoded) 111 ,(* count 7)))))) 112 ((< count 0) 113 (let ((days-in-month (cl-gensym)) 114 (decoded (cl-gensym))) 115 `(let* ((,decoded (decode-time date)) 116 (,days-in-month (ledger-schedule-days-in-month 117 (nth 4 ,decoded) 118 (nth 5 ,decoded)))) 119 (and (eq (nth 6 ,decoded) ,day-of-week) 120 (<= (+ ,days-in-month ,(* count 7)) 121 (nth 3 ,decoded) 122 (+ ,days-in-month ,(* (1+ count) 7))))))) 123 (t 124 (error "COUNT out of range, COUNT=%S" count))) 125 (error "Invalid argument to ledger-schedule-day-in-month-macro %S %S" 126 count 127 day-of-week))) 128 129 (defun ledger-schedule-constrain-every-count-day (day-of-week skip start-date) 130 "Return a form that is true for every DAY-OF-WEEK. 131 Skips SKIP, and starts on START-DATE. 132 For example every second Friday, regardless of month." 133 (let ((start-day (nth 6 (decode-time start-date)))) 134 (if (eq start-day day-of-week) ;; good, can proceed 135 `(zerop (mod (- (time-to-days date) ,(time-to-days start-date)) ,(* skip 7))) 136 (error "START-DATE day of week doesn't match DAY-OF-WEEK")))) 137 138 (defun ledger-schedule-constrain-date-range (month1 day1 month2 day2) 139 "Return a form of DATE that is true if DATE falls between two dates. 140 The dates are given by the pairs MONTH1 DAY1 and MONTH2 DAY2." 141 (let ((decoded (cl-gensym)) 142 (target-month (cl-gensym)) 143 (target-day (cl-gensym))) 144 `(let* ((,decoded (decode-time date)) 145 (,target-month (nth 4 decoded)) 146 (,target-day (nth 3 decoded))) 147 (and (and (> ,target-month ,month1) 148 (< ,target-month ,month2)) 149 (and (> ,target-day ,day1) 150 (< ,target-day ,day2)))))) 151 152 153 154 (defun ledger-schedule-scan-transactions (schedule-file) 155 "Scan SCHEDULE-FILE and return a list of transactions with date predicates. 156 The car of each item is a function of date that returns true if 157 the transaction should be logged for that day." 158 (interactive "fFile name: ") 159 (let ((xact-list (list))) 160 (with-current-buffer 161 (find-file-noselect schedule-file) 162 (goto-char (point-min)) 163 (while (re-search-forward "^\\[\\(.*\\)\\] " nil t) 164 (let ((date-descriptor "") 165 (transaction nil) 166 (xact-start (match-end 0))) 167 (setq date-descriptor 168 (ledger-schedule-read-descriptor-tree 169 (buffer-substring-no-properties 170 (match-beginning 0) 171 (match-end 0)))) 172 (forward-paragraph) 173 (setq transaction (list date-descriptor 174 (buffer-substring-no-properties 175 xact-start 176 (point)))) 177 (setq xact-list (cons transaction xact-list)))) 178 xact-list))) 179 180 (defun ledger-schedule-read-descriptor-tree (descriptor-string) 181 "Read DESCRIPTOR-STRING and return a form that evaluates dates." 182 (ledger-schedule-transform-auto-tree 183 (split-string 184 (substring descriptor-string 1 (string-match "]" descriptor-string)) " "))) 185 186 (defun ledger-schedule-transform-auto-tree (descriptor-string-list) 187 "Take DESCRIPTOR-STRING-LIST, and return a string with a lambda function of date." 188 ;; use funcall to use the lambda function spit out here 189 (if (consp descriptor-string-list) 190 (let (result) 191 (while (consp descriptor-string-list) 192 (let ((newcar (car descriptor-string-list))) 193 (if (consp newcar) 194 (setq newcar (ledger-schedule-transform-auto-tree (car descriptor-string-list)))) 195 ;; newcar may be a cons now, after ledger-schedule-transfrom-auto-tree 196 (if (consp newcar) 197 (push newcar result) 198 ;; this is where we actually turn the string descriptor into useful lisp 199 (push (ledger-schedule-compile-constraints newcar) result)) ) 200 (setq descriptor-string-list (cdr descriptor-string-list))) 201 202 ;; tie up all the clauses in a big or lambda, and return 203 ;; the lambda function as list to be executed by funcall 204 `(lambda (date) 205 ,(nconc (list 'or) (nreverse result) descriptor-string-list))))) 206 207 (defun ledger-schedule-compile-constraints (descriptor-string) 208 "Return a list with the year, month and day fields split." 209 (let ((fields (split-string descriptor-string "[/\\-]" t))) 210 (list 'and 211 (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields)) 212 (ledger-schedule-constrain-year (nth 0 fields) (nth 1 fields) (nth 2 fields)) 213 (ledger-schedule-constrain-month (nth 0 fields) (nth 1 fields) (nth 2 fields))))) 214 215 (defun ledger-schedule-constrain-year (year-desc month-desc day-desc) 216 "Return a form that constrains the year. 217 218 YEAR-DESC, MONTH-DESC, and DAY-DESC are the string portions of the 219 date descriptor." 220 (cond 221 ((string-match "[A-Za-z]" day-desc) t) ; there is an advanced day descriptor which overrides the year 222 ((string= year-desc "*") t) 223 ((/= 0 (string-to-number year-desc)) 224 `(memq (nth 5 (decode-time date)) ',(mapcar 'string-to-number (split-string year-desc ",")))) 225 (t 226 (error "Improperly specified year constraint: %s %s %s" year-desc month-desc day-desc)))) 227 228 (defun ledger-schedule-constrain-month (year-desc month-desc day-desc) 229 "Return a form that constrains the month. 230 231 YEAR-DESC, MONTH-DESC, and DAY-DESC are the string portions of the 232 date descriptor." 233 (cond 234 ((string-match "[A-Za-z]" day-desc) t) ; there is an advanced day descriptor which overrides the month 235 ((string= month-desc "*") 236 t) ;; always match 237 ((string= month-desc "E") ;; Even 238 `(cl-evenp (nth 4 (decode-time date)))) 239 ((string= month-desc "O") ;; Odd 240 `(cl-oddp (nth 4 (decode-time date)))) 241 ((/= 0 (string-to-number month-desc)) ;; Starts with number 242 `(memq (nth 4 (decode-time date)) ',(mapcar 'string-to-number (split-string month-desc ",")))) 243 (t 244 (error "Improperly specified month constraint: %s %s %s" year-desc month-desc day-desc)))) 245 246 (defun ledger-schedule-constrain-day (year-desc month-desc day-desc) 247 "Return a form that constrains the day. 248 249 YEAR-DESC, MONTH-DESC, and DAY-DESC are the string portions of the 250 date descriptor." 251 (cond ((string= day-desc "*") 252 t) 253 ((string= day-desc "L") 254 `(= (nth 3 (decode-time date)) (ledger-schedule-days-in-month (nth 4 (decode-time date)) (nth 5 (decode-time date))))) 255 ((string-match "[A-Za-z]" day-desc) ;; There is something other than digits and commas 256 (ledger-schedule-parse-complex-date year-desc month-desc day-desc)) 257 ((/= 0 (string-to-number day-desc)) 258 `(memq (nth 3 (decode-time date)) ',(mapcar 'string-to-number (split-string day-desc ",")))) 259 (t 260 (error "Improperly specified day constraint: %s %s %s" year-desc month-desc day-desc)))) 261 262 263 264 (defun ledger-schedule-parse-complex-date (year-desc month-desc day-desc) 265 "Parse day descriptors that have repeats." 266 (let ((years (mapcar 'string-to-number (split-string year-desc ","))) 267 (months (mapcar 'string-to-number (split-string month-desc ","))) 268 (day-parts (split-string day-desc "\\+")) 269 (every-nth (string-match "\\+" day-desc))) 270 (if every-nth 271 (let ((base-day (string-to-number (car day-parts))) 272 (increment (string-to-number (substring (cadr day-parts) 0 273 (string-match "[A-Za-z]" (cadr day-parts))))) 274 (day-of-week (ledger-schedule-encode-day-of-week 275 (substring (cadr day-parts) (string-match "[A-Za-z]" (cadr day-parts)))))) 276 (ledger-schedule-constrain-every-count-day day-of-week increment (encode-time 0 0 0 base-day (car months) (car years)))) 277 (let ((count (string-to-number (substring (car day-parts) 0 1))) 278 (day-of-week (ledger-schedule-encode-day-of-week 279 (substring (car day-parts) (string-match "[A-Za-z]" (car day-parts)))))) 280 (ledger-schedule-constrain-day-in-month count day-of-week))))) 281 282 (defun ledger-schedule-list-upcoming-xacts (candidate-items early horizon) 283 "Search CANDIDATE-ITEMS for xacts that occur within the given period. 284 The period runs from (today - EARLY) to (today + HORIZON)." 285 (let ((start-date (time-subtract (current-time) (days-to-time early))) 286 test-date items) 287 (cl-loop for day from 0 to (+ early horizon) by 1 do 288 (setq test-date (time-add start-date (days-to-time day))) 289 (dolist (candidate candidate-items items) 290 (if (funcall (car candidate) test-date) 291 (setq items (append items (list (list test-date (cadr candidate)))))))) 292 items)) 293 294 (defun ledger-schedule-create-auto-buffer (candidate-items early horizon) 295 "Format CANDIDATE-ITEMS for display." 296 (let ((candidates (ledger-schedule-list-upcoming-xacts candidate-items early horizon)) 297 (schedule-buf (get-buffer-create ledger-schedule-buffer-name))) 298 (with-current-buffer schedule-buf 299 (erase-buffer) 300 (dolist (candidate candidates) 301 (insert (ledger-format-date (car candidate) ) " " (cadr candidate) "\n")) 302 (ledger-mode)) 303 (length candidates))) 304 305 (defun ledger-schedule-upcoming (file look-backward look-forward) 306 "Generate upcoming transactions. 307 308 FILE is the file containing the scheduled transaction, 309 default to `ledger-schedule-file'. 310 LOOK-BACKWARD is the number of days in the past to look at 311 default to `ledger-schedule-look-backward' 312 LOOK-FORWARD is the number of days in the future to look at 313 default to `ledger-schedule-look-forward' 314 315 Use a prefix arg to change the default value" 316 (interactive (if current-prefix-arg 317 (list (read-file-name "Schedule File: " () ledger-schedule-file t) 318 (read-number "Look backward: " ledger-schedule-look-backward) 319 (read-number "Look forward: " ledger-schedule-look-forward)) 320 (list ledger-schedule-file ledger-schedule-look-backward ledger-schedule-look-forward))) 321 (unless (and file (file-exists-p file)) 322 (error "Could not find ledger schedule file at %s" file)) 323 (ledger-schedule-create-auto-buffer 324 (ledger-schedule-scan-transactions file) 325 look-backward 326 look-forward) 327 (pop-to-buffer ledger-schedule-buffer-name)) 328 329 330 (provide 'ledger-schedule) 331 332 ;;; ledger-schedule.el ends here