333 lines
14 KiB
EmacsLisp
333 lines
14 KiB
EmacsLisp
;;; ledger-schedule.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2013 Craig Earls (enderw88 at gmail dot com)
|
|
|
|
;; This file is not part of GNU Emacs.
|
|
|
|
;; This is free software; you can redistribute it and/or modify it
|
|
;; under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2, or (at your option)
|
|
;; any later version.
|
|
;;
|
|
;; This is distributed in the hope that it will be useful, but WITHOUT
|
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
|
|
;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
|
|
;; License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
|
|
;; MA 02110-1301 USA.
|
|
|
|
;;; Commentary:
|
|
;;
|
|
;; This module provides for automatically adding transactions to a
|
|
;; ledger buffer on a periodic basis. Recurrence expressions are
|
|
;; inspired by Martin Fowler's "Recurring Events for Calendars",
|
|
;; martinfowler.com/apsupp/recurring.pdf
|
|
|
|
;; use (fset 'VARNAME (macro args)) to put the macro definition in the
|
|
;; function slot of the symbol VARNAME. Then use VARNAME as the
|
|
;; function without have to use funcall.
|
|
|
|
|
|
(require 'ledger-init)
|
|
(require 'cl-lib)
|
|
|
|
(declare-function ledger-mode "ledger-mode")
|
|
;;; Code:
|
|
|
|
(defgroup ledger-schedule nil
|
|
"Support for automatically recommendation transactions."
|
|
:group 'ledger)
|
|
|
|
(defcustom ledger-schedule-buffer-name "*Ledger Schedule*"
|
|
"Name for the schedule buffer."
|
|
:type 'string
|
|
:group 'ledger-schedule)
|
|
|
|
(defcustom ledger-schedule-look-backward 7
|
|
"Number of days to look back in time for transactions."
|
|
:type 'integer
|
|
:group 'ledger-schedule)
|
|
|
|
(defcustom ledger-schedule-look-forward 14
|
|
"Number of days auto look forward to recommend transactions."
|
|
:type 'integer
|
|
:group 'ledger-schedule)
|
|
|
|
(defcustom ledger-schedule-file "~/ledger-schedule.ledger"
|
|
"File to find scheduled transactions."
|
|
:type 'file
|
|
:group 'ledger-schedule)
|
|
|
|
(defcustom ledger-schedule-week-days '(("Mo" 1)
|
|
("Tu" 2)
|
|
("We" 3)
|
|
("Th" 4)
|
|
("Fr" 5)
|
|
("Sa" 6)
|
|
("Su" 0))
|
|
"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 :key-type string :value-type (group integer))
|
|
:group 'ledger-schedule)
|
|
|
|
(defsubst ledger-between (val low high)
|
|
"Return TRUE if VAL >= LOW and <= HIGH."
|
|
(declare (obsolete <= "Ledger-mode v4.0.1"))
|
|
(<= 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 (<= 1 month 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."
|
|
(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 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)"
|
|
(if (and (<= -6 count 6) (<= 0 day-of-week 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)
|
|
(<= ,(* (1- count) 7)
|
|
(nth 3 ,decoded)
|
|
,(* 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)
|
|
(<= (+ ,days-in-month ,(* count 7))
|
|
(nth 3 ,decoded)
|
|
(+ ,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-OF-WEEK.
|
|
Skips SKIP, and starts 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
|
|
`(zerop (mod (- (time-to-days date) ,(time-to-days 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 two dates.
|
|
The dates are given by the pairs MONTH1 DAY1 and MONTH2 DAY2."
|
|
(let ((decoded (gensym))
|
|
(target-month (gensym))
|
|
(target-day (gensym)))
|
|
`(let* ((,decoded (decode-time date))
|
|
(,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))))))
|
|
|
|
|
|
|
|
(defun ledger-schedule-scan-transactions (schedule-file)
|
|
"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: ")
|
|
(let ((xact-list (list)))
|
|
(with-current-buffer
|
|
(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-descriptor
|
|
(ledger-schedule-read-descriptor-tree
|
|
(buffer-substring-no-properties
|
|
(match-beginning 0)
|
|
(match-end 0))))
|
|
(forward-paragraph)
|
|
(setq transaction (list date-descriptor
|
|
(buffer-substring-no-properties
|
|
xact-start
|
|
(point))))
|
|
(setq xact-list (cons transaction xact-list))))
|
|
xact-list)))
|
|
|
|
(defun ledger-schedule-read-descriptor-tree (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)
|
|
"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)
|
|
(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 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)))
|
|
(list 'and
|
|
(ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields))
|
|
(ledger-schedule-constrain-year (nth 0 fields) (nth 1 fields) (nth 2 fields))
|
|
(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, MONTH-DESC, and DAY-DESC are the string portions of the
|
|
date descriptor."
|
|
(cond
|
|
((string-match "[A-Za-z]" day-desc) t) ; there is an advanced day descriptor which overrides the year
|
|
((string= year-desc "*") t)
|
|
((/= 0 (string-to-number year-desc))
|
|
`(memq (nth 5 (decode-time date)) ',(mapcar 'string-to-number (split-string year-desc ","))))
|
|
(t
|
|
(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, MONTH-DESC, and DAY-DESC are the string portions of the
|
|
date descriptor."
|
|
(cond
|
|
((string-match "[A-Za-z]" day-desc) t) ; there is an advanced day descriptor which overrides the month
|
|
((string= month-desc "*")
|
|
t) ;; always match
|
|
((string= month-desc "E") ;; Even
|
|
`(cl-evenp (nth 4 (decode-time date))))
|
|
((string= month-desc "O") ;; Odd
|
|
`(cl-oddp (nth 4 (decode-time date))))
|
|
((/= 0 (string-to-number month-desc)) ;; Starts with number
|
|
`(memq (nth 4 (decode-time date)) ',(mapcar 'string-to-number (split-string month-desc ","))))
|
|
(t
|
|
(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, MONTH-DESC, and DAY-DESC are the string portions of the
|
|
date descriptor."
|
|
(cond ((string= day-desc "*")
|
|
t)
|
|
((string= day-desc "L")
|
|
`(= (nth 3 (decode-time date)) (ledger-schedule-days-in-month (nth 4 (decode-time date)) (nth 5 (decode-time date)))))
|
|
((string-match "[A-Za-z]" day-desc) ;; There is something other than digits and commas
|
|
(ledger-schedule-parse-complex-date year-desc month-desc day-desc))
|
|
((/= 0 (string-to-number day-desc))
|
|
`(memq (nth 3 (decode-time date)) ',(mapcar 'string-to-number (split-string day-desc ","))))
|
|
(t
|
|
(error "Improperly specified day constraint: %s %s %s" year-desc month-desc day-desc))))
|
|
|
|
|
|
|
|
(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 "\\+"))
|
|
(every-nth (string-match "\\+" day-desc)))
|
|
(if every-nth
|
|
(let ((base-day (string-to-number (car day-parts)))
|
|
(increment (string-to-number (substring (cadr day-parts) 0
|
|
(string-match "[A-Za-z]" (cadr day-parts)))))
|
|
(day-of-week (ledger-schedule-encode-day-of-week
|
|
(substring (cadr day-parts) (string-match "[A-Za-z]" (cadr day-parts))))))
|
|
(ledger-schedule-constrain-every-count-day day-of-week increment (encode-time 0 0 0 base-day (car months) (car years))))
|
|
(let ((count (string-to-number (substring (car day-parts) 0 1)))
|
|
(day-of-week (ledger-schedule-encode-day-of-week
|
|
(substring (car day-parts) (string-match "[A-Za-z]" (car day-parts))))))
|
|
(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 given period.
|
|
The period runs from (today - EARLY) to (today + HORIZON)."
|
|
(let ((start-date (time-subtract (current-time) (days-to-time early)))
|
|
test-date items)
|
|
(cl-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))))))))
|
|
items))
|
|
|
|
(defun ledger-schedule-create-auto-buffer (candidate-items early horizon)
|
|
"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)))
|
|
(with-current-buffer schedule-buf
|
|
(erase-buffer)
|
|
(dolist (candidate candidates)
|
|
(insert (ledger-format-date (car candidate) ) " " (cadr candidate) "\n"))
|
|
(ledger-mode))
|
|
(length candidates)))
|
|
|
|
(defun ledger-schedule-upcoming (file look-backward look-forward)
|
|
"Generate upcoming transactions.
|
|
|
|
FILE is the file containing the scheduled transaction,
|
|
default to `ledger-schedule-file'.
|
|
LOOK-BACKWARD is the number of days in the past to look at
|
|
default to `ledger-schedule-look-backward'
|
|
LOOK-FORWARD is the number of days in the future to look at
|
|
default to `ledger-schedule-look-forward'
|
|
|
|
Use a prefix arg to change the default value"
|
|
(interactive (if current-prefix-arg
|
|
(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)))
|
|
(unless (and file (file-exists-p file))
|
|
(error "Could not find ledger schedule file at %s" file))
|
|
(ledger-schedule-create-auto-buffer
|
|
(ledger-schedule-scan-transactions file)
|
|
look-backward
|
|
look-forward)
|
|
(pop-to-buffer ledger-schedule-buffer-name))
|
|
|
|
|
|
(provide 'ledger-schedule)
|
|
|
|
;;; ledger-schedule.el ends here
|