diff options
Diffstat (limited to 'lisp/ledger-schedule.el')
| -rw-r--r-- | lisp/ledger-schedule.el | 254 |
1 files changed, 127 insertions, 127 deletions
diff --git a/lisp/ledger-schedule.el b/lisp/ledger-schedule.el index e1e06d69..8e2ab1f6 100644 --- a/lisp/ledger-schedule.el +++ b/lisp/ledger-schedule.el @@ -62,17 +62,17 @@ (and (>= val low) (<= val high))) (defun ledger-schedule-check-available () - (setq ledger-schedule-available (and ledger-schedule-file - (file-exists-p ledger-schedule-file)))) + (setq ledger-schedule-available (and ledger-schedule-file + (file-exists-p ledger-schedule-file)))) (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 (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))) + 29 + (nth (1- month) '(31 28 31 30 31 30 31 31 30 31 30 31))) + (error "Month out of range, MONTH=%S" month))) ;; Macros to handle date expressions @@ -83,51 +83,51 @@ month. Negative COUNT starts from the end of the month. (EQ COUNT 0) means EVERY day-of-week (eg. every Saturday)" (if (and (between count -6 6) (between day-of-week 0 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 (gensym))) - `(let ((,decoded (decode-time date))) - (and (eq (nth 6 ,decoded) ,day-of-week) - (between (nth 3 ,decoded) - ,(* (1- count) 7) - ,(* count 7)))))) - ((< count 0) - (let ((days-in-month (gensym)) - (decoded (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) - (between (nth 3 ,decoded) - (+ ,days-in-month ,(* count 7)) - (+ ,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))) + `(eq (nth 6 (decode-time date)) ,day-of-week)) + ((> count 0) ;; Positive count + (let ((decoded (gensym))) + `(let ((,decoded (decode-time date))) + (and (eq (nth 6 ,decoded) ,day-of-week) + (between (nth 3 ,decoded) + ,(* (1- count) 7) + ,(* count 7)))))) + ((< count 0) + (let ((days-in-month (gensym)) + (decoded (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) + (between (nth 3 ,decoded) + (+ ,days-in-month ,(* count 7)) + (+ ,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 skipping SKIP, starting on START. For example every second Friday, regardless of month." (let ((start-day (nth 6 (decode-time (eval start-date))))) - (if (eq start-day day-of-week) ;; good, can proceed - `(zerop (mod (- (time-to-days date) ,(time-to-days (eval start-date))) ,(* skip 7))) - (error "START-DATE day of week doesn't match DAY-OF-WEEK")))) + (if (eq start-day day-of-week) ;; good, can proceed + `(zerop (mod (- (time-to-days date) ,(time-to-days (eval 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 (gensym)) - (target-month (gensym)) - (target-day (gensym))) + (target-month (gensym)) + (target-day (gensym))) `(let* ((,decoded (decode-time date)) - (,target-month (nth 4 decoded)) - (,target-day (nth 3 decoded))) + (,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)))))) + (< ,target-month ,month2)) + (and (> ,target-day ,day1) + (< ,target-day ,day2)))))) (defun ledger-schedule-is-holiday (date) @@ -140,46 +140,46 @@ the transaction should be logged for that day." (interactive "fFile name: ") (let ((xact-list (list))) (with-current-buffer - (find-file-noselect schedule-file) + (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-descriptors - (ledger-schedule-read-descriptor-tree - (buffer-substring-no-properties - (match-beginning 0) - (match-end 0)))) - (forward-paragraph) - (setq transaction (list date-descriptors - (buffer-substring-no-properties - xact-start - (point)))) - (setq xact-list (cons transaction xact-list)))) - xact-list))) + (let ((date-descriptor "") + (transaction nil) + (xact-start (match-end 0))) + (setq date-descriptors + (ledger-schedule-read-descriptor-tree + (buffer-substring-no-properties + (match-beginning 0) + (match-end 0)))) + (forward-paragraph) + (setq transaction (list date-descriptors + (buffer-substring-no-properties + xact-start + (point)))) + (setq xact-list (cons transaction xact-list)))) + xact-list))) (defun ledger-schedule-replace-brackets () - "Replace all brackets with parens" - (goto-char (point-min)) - (while (search-forward "]" nil t) - (replace-match ")" nil t)) - (goto-char (point-min)) - (while (search-forward "[" nil t) - (replace-match "(" nil t))) + "Replace all brackets with parens" + (goto-char (point-min)) + (while (search-forward "]" nil t) + (replace-match ")" nil t)) + (goto-char (point-min)) + (while (search-forward "[" nil t) + (replace-match "(" nil t))) (defvar ledger-schedule-descriptor-regex - (concat "\\(20[0-9][0-9]\\|[\*]\\)[/\\-]" ;; Year slot - "\\([\*EO]\\|[01][0-9]\\)[/\\-]" ;; Month slot - "\\([\*]\\|\\([0-3][0-9]\\)\\|" - "\\([0-5]" - "\\(\\(Su\\)\\|" - "\\(Mo\\)\\|" - "\\(Tu\\)\\|" - "\\(We\\)\\|" - "\\(Th\\)\\|" - "\\(Fr\\)\\|" - "\\(Sa\\)\\)\\)\\)")) + (concat "\\(20[0-9][0-9]\\|[\*]\\)[/\\-]" ;; Year slot + "\\([\*EO]\\|[01][0-9]\\)[/\\-]" ;; Month slot + "\\([\*]\\|\\([0-3][0-9]\\)\\|" + "\\([0-5]" + "\\(\\(Su\\)\\|" + "\\(Mo\\)\\|" + "\\(Tu\\)\\|" + "\\(We\\)\\|" + "\\(Th\\)\\|" + "\\(Fr\\)\\|" + "\\(Sa\\)\\)\\)\\)")) (defun ledger-schedule-read-descriptor-tree (descriptor-string) "Take a date DESCRIPTOR-STRING and return a function of date that @@ -194,11 +194,11 @@ returns true if the date meets the requirements" (goto-char (point-max)) ;; double quote all the descriptors for string processing later (while (re-search-backward ledger-schedule-descriptor-regex nil t) ;; Day slot - (goto-char - (match-end 0)) - (insert ?\") - (goto-char (match-beginning 0)) - (insert "\"" ))) + (goto-char + (match-end 0)) + (insert ?\") + (goto-char (match-beginning 0)) + (insert "\"" ))) ;; read the descriptor string into a lisp object the transform the ;; string descriptor into useable things @@ -206,30 +206,30 @@ returns true if the date meets the requirements" (read (buffer-substring-no-properties (point-min) (point-max)))))) (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." -;; use funcall to use the lambda function spit out here + "Takes a lisp list of date descriptor strings, TREE, and returns 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 and lambda, and return - ;; the lambda function as list to be executed by funcall - `(lambda (date) - ,(nconc (list 'or) (nreverse result) descriptor-string-list))))) + (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 and 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)) - constrain-year constrain-month constrain-day) + constrain-year constrain-month constrain-day) (setq constrain-year (ledger-schedule-constrain-year (nth 0 fields))) (setq constrain-month (ledger-schedule-constrain-month (nth 1 fields))) (setq constrain-day (ledger-schedule-constrain-day (nth 2 fields))) @@ -239,32 +239,32 @@ returns true if the date meets the requirements" (defun ledger-schedule-constrain-year (str) (let ((year-match t)) (cond ((string= str "*") - year-match) - ((/= 0 (setq year-match (string-to-number str))) - `(eq (nth 5 (decode-time date)) ,year-match)) - (t - (error "Improperly specified year constraint: %s" str))))) + year-match) + ((/= 0 (setq year-match (string-to-number str))) + `(eq (nth 5 (decode-time date)) ,year-match)) + (t + (error "Improperly specified year constraint: %s" str))))) (defun ledger-schedule-constrain-month (str) (let ((month-match t)) (cond ((string= str "*") - month-match) ;; always match - ((/= 0 (setq month-match (string-to-number str))) - (if (between month-match 1 12) ;; no month specified, assume 31 days. - `(eq (nth 4 (decode-time date)) ,month-match) - (error "ledger-schedule-constrain-numerical-month: month out of range %S" month-match))) - (t - (error "Improperly specified month constraint: %s" str))))) + month-match) ;; always match + ((/= 0 (setq month-match (string-to-number str))) + (if (between month-match 1 12) ;; no month specified, assume 31 days. + `(eq (nth 4 (decode-time date)) ,month-match) + (error "ledger-schedule-constrain-numerical-month: month out of range %S" month-match))) + (t + (error "Improperly specified month constraint: %s" str))))) (defun ledger-schedule-constrain-day (str) (let ((day-match t)) (cond ((string= str "*") - t) - ((/= 0 (setq day-match (string-to-number str))) - `(eq (nth 3 (decode-time date)) ,day-match)) - (t - (error "Improperly specified day constraint: %s" str))))) + t) + ((/= 0 (setq day-match (string-to-number str))) + `(eq (nth 3 (decode-time date)) ,day-match)) + (t + (error "Improperly specified day constraint: %s" str))))) (defun ledger-schedule-parse-date-descriptor (descriptor) "Parse the date descriptor, return the evaluator" @@ -273,31 +273,31 @@ returns true if the date meets the requirements" (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) + test-date items) (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)))))))) + (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-already-entered (candidate buffer) (let ((target-date (format-time-string date-format (car candidate))) - (target-payee (cadr 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)) - (schedule-buf (get-buffer-create ledger-schedule-buffer-name)) - (date-format (or (cdr (assoc "date-format" ledger-environment-alist)) - ledger-default-date-format))) + (schedule-buf (get-buffer-create ledger-schedule-buffer-name)) + (date-format (or (cdr (assoc "date-format" ledger-environment-alist)) + ledger-default-date-format))) (with-current-buffer schedule-buf (erase-buffer) - (dolist (candidate candidates) - (if (not (ledger-schedule-already-entered candidate ledger-buf)) - (insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n"))) - (ledger-mode)) + (dolist (candidate candidates) + (if (not (ledger-schedule-already-entered candidate ledger-buf)) + (insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n"))) + (ledger-mode)) (length candidates))) (defun ledger-schedule-upcoming (file look-backward look-forward) @@ -315,7 +315,7 @@ Use a prefix arg to change the default value" (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))) + (list ledger-schedule-file ledger-schedule-look-backward ledger-schedule-look-forward))) (ledger-schedule-create-auto-buffer (ledger-schedule-scan-transactions file) look-backward |