diff options
Diffstat (limited to 'lisp/ledger-schedule.el')
| -rw-r--r-- | lisp/ledger-schedule.el | 104 |
1 files changed, 60 insertions, 44 deletions
diff --git a/lisp/ledger-schedule.el b/lisp/ledger-schedule.el index a5e7decb..9411bd15 100644 --- a/lisp/ledger-schedule.el +++ b/lisp/ledger-schedule.el @@ -22,7 +22,7 @@ ;;; Commentary: ;; ;; This module provides for automatically adding transactions to a -;; ledger buffer on a periodic basis. Recurrence expressions are +;; ledger buffer on a periodic basis. Recurrence expressions are ;; inspired by Martin Fowler's "Recurring Events for Calendars", ;; martinfowler.com/apsupp/recurring.pdf @@ -32,12 +32,14 @@ (require 'ledger-init) +;;; Code: + (defgroup ledger-schedule nil "Support for automatically recommendation transactions." :group 'ledger) (defcustom ledger-schedule-buffer-name "*Ledger Schedule*" - "Name for the schedule buffer" + "Name for the schedule buffer." :type 'string :group 'ledger-schedule) @@ -47,7 +49,7 @@ :group 'ledger-schedule) (defcustom ledger-schedule-look-forward 14 - "Number of days auto look forward to recommend transactions" + "Number of days auto look forward to recommend transactions." :type 'integer :group 'ledger-schedule) @@ -56,37 +58,40 @@ :type 'file :group 'ledger-schedule) -(defvar ledger-schedule-available nil) +(defcustom ledger-schedule-week-days '(("Mo" 1) + ("Tu" 2) + ("We" 3) + ("Th" 4) + ("Fr" 5) + ("Sa" 6) + ("Su" 7)) + "List of weekday abbreviations. There must be exactly seven +entries each with a two character abbreviation for a day and the +number of that day in the week. " + :type '(alist :value-type (group integer)) + :group 'ledger-schedule) (defsubst between (val low high) - (and (>= val low) (<= val high))) - -(defun ledger-schedule-check-available () - (setq ledger-schedule-available (and ledger-schedule-file - (file-exists-p ledger-schedule-file)))) + "Return TRUE if VAL > LOW and < HIGH." + (and (>= val low) (<= val high))) (defun ledger-schedule-days-in-month (month year) "Return number of days in the MONTH, MONTH is from 1 to 12. -If year is nil, assume it is not a leap year" +If YEAR is nil, assume it is not a leap year" (if (between month 1 12) (if (and year (date-leap-year-p year) (= 2 month)) 29 (nth (1- month) '(31 28 31 30 31 30 31 31 30 31 30 31))) (error "Month out of range, MONTH=%S" month))) -(defun ledger-schedule-encode-day-of-week ( day-string) - "return the numerical day of week corresponding to DAY-STRING" - (cond ((string= day-string "Su") 7) - ((string= day-string "Mo") 1) - ((string= day-string "Tu") 2) - ((string= day-string "We") 3) - ((string= day-string "Th") 4) - ((string= day-string "Fr") 5) - ((string= day-string "Sa") 6))) +(defun ledger-schedule-encode-day-of-week (day-string) + "Return the numerical day of week corresponding to DAY-STRING." + (cadr (assoc day-string ledger-schedule-week-days))) + ;; Macros to handle date expressions (defun ledger-schedule-constrain-day-in-month (count day-of-week) - "Return a form that evaluates DATE that returns true for the COUNT DAY-OF-WEEK. + "Return a form that returns TRUE for the the COUNT DAY-OF-WEEK. For example, return true if date is the 3rd Thursday of the month. Negative COUNT starts from the end of the month. (EQ COUNT 0) means EVERY day-of-week (eg. every Saturday)" @@ -118,7 +123,7 @@ COUNT 0) means EVERY day-of-week (eg. every Saturday)" day-of-week))) (defun ledger-schedule-constrain-every-count-day (day-of-week skip start-date) - "Return a form that is true for every DAY skipping SKIP, starting on START. + "Return a form that is true for every DAY-OF-WEEK skipping SKIP, starting on START-DATE. For example every second Friday, regardless of month." (let ((start-day (nth 6 (decode-time start-date)))) (if (eq start-day day-of-week) ;; good, can proceed @@ -139,12 +144,9 @@ For example every second Friday, regardless of month." (< ,target-day ,day2)))))) -(defun ledger-schedule-is-holiday (date) - "Return true if DATE is a holiday." - nil) (defun ledger-schedule-scan-transactions (schedule-file) - "Scans SCHEDULE-FILE and returns a list of transactions with date predicates. + "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: ") @@ -156,13 +158,13 @@ the transaction should be logged for that day." (let ((date-descriptor "") (transaction nil) (xact-start (match-end 0))) - (setq date-descriptors + (setq date-descriptor (ledger-schedule-read-descriptor-tree (buffer-substring-no-properties (match-beginning 0) (match-end 0)))) (forward-paragraph) - (setq transaction (list date-descriptors + (setq transaction (list date-descriptor (buffer-substring-no-properties xact-start (point)))) @@ -170,10 +172,13 @@ the transaction should be logged for that day." xact-list))) (defun ledger-schedule-read-descriptor-tree (descriptor-string) - (ledger-schedule-transform-auto-tree (split-string (substring descriptor-string 1 (string-match "]" 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) - "Takes a lisp list of date descriptor strings, TREE, and returns a string with a lambda function of date." + "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) @@ -194,7 +199,7 @@ the transaction should be logged for that day." ,(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" + "Return a list with the year, month and day fields split." (let ((fields (split-string descriptor-string "[/\\-]" t))) (if (string-match "[A-Za-z]" descriptor-string) (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields)) @@ -204,6 +209,10 @@ the transaction should be logged for that day." (ledger-schedule-constrain-month (nth 0 fields) (nth 1 fields) (nth 2 fields)))))) (defun ledger-schedule-constrain-year (year-desc month-desc day-desc) + "Return a form that constrains the year. + +YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the +date descriptor." (cond ((string= year-desc "*") t) ((/= 0 (string-to-number year-desc)) `(memq (nth 5 (decode-time date)) ',(mapcar 'string-to-number (split-string year-desc ",")))) @@ -211,6 +220,10 @@ the transaction should be logged for that day." (error "Improperly specified year constraint: %s %s %s" year-desc month-desc day-desc)))) (defun ledger-schedule-constrain-month (year-desc month-desc day-desc) + "Return a form that constrains the month. + +YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the +date descriptor." (cond ((string= month-desc "*") t) ;; always match ((string= month-desc "E") ;; Even @@ -223,6 +236,10 @@ the transaction should be logged for that day." (error "Improperly specified month constraint: %s %s %s" year-desc month-desc day-desc)))) (defun ledger-schedule-constrain-day (year-desc month-desc day-desc) + "Return a form that constrains the day. + +YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the +date descriptor." (cond ((string= day-desc "*") t) ((string-match "[A-Za-z]" day-desc) ;; There is something other than digits and commas @@ -235,6 +252,7 @@ the transaction should be logged for that day." (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 "+")) @@ -252,7 +270,7 @@ the transaction should be logged for that day." (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" + "Search CANDIDATE-ITEMS for xacts that occur within the period today - EARLY to today + HORIZON." (let ((start-date (time-subtract (current-time) (days-to-time early))) test-date items) (loop for day from 0 to (+ early horizon) by 1 do @@ -262,12 +280,6 @@ the transaction should be logged for that day." (setq items (append items (list (list test-date (cadr candidate)))))))) items)) -(defun ledger-schedule-already-entered (candidate buffer) - "return TRUE if CANDIDATE is already in BUFFER" - (let ((target-date (format-time-string date-format (car candidate))) - (target-payee (cadr candidate))) - nil)) - (defun ledger-schedule-create-auto-buffer (candidate-items early horizon ledger-buf) "Format CANDIDATE-ITEMS for display." (let ((candidates (ledger-schedule-list-upcoming-xacts candidate-items early horizon)) @@ -283,7 +295,7 @@ the transaction should be logged for that day." (length candidates))) (defun ledger-schedule-upcoming (file look-backward look-forward) - "Generate upcoming transaction + "Generate upcoming transactions. FILE is the file containing the scheduled transaction, default to `ledger-schedule-file'. @@ -298,12 +310,16 @@ Use a prefix arg to change the default value" (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))) - (ledger-schedule-create-auto-buffer - (ledger-schedule-scan-transactions file) - look-backward - look-forward - (current-buffer)) - (pop-to-buffer ledger-schedule-buffer-name)) + (if (and ledger-schedule-file + (file-exists-p ledger-schedule-file)) + (progn + (ledger-schedule-create-auto-buffer + (ledger-schedule-scan-transactions file) + look-backward + look-forward + (current-buffer)) + (pop-to-buffer ledger-schedule-buffer-name)) + (error "Could not find ledger schedule file at %s" ledger-schedule-file))) (provide 'ledger-schedule) |