summaryrefslogtreecommitdiff
path: root/ledger-schedule.el
blob: 3a3e0ef57451ece3da921b316acc3a5632b6c8dc (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
;;; 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 :value-type (group integer))
  :group 'ledger-schedule)

(defsubst ledger-between (val low high)
  "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 (ledger-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."
  (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 (ledger-between count -6 6) (ledger-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 (cl-gensym)))
               `(let ((,decoded (decode-time date)))
                  (and (eq (nth 6 ,decoded) ,day-of-week)
                       (ledger-between  (nth 3 ,decoded)
                                        ,(* (1- count) 7)
                                        ,(* count 7))))))
            ((< count 0)
             (let ((days-in-month (cl-gensym))
                   (decoded (cl-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)
                       (ledger-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-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
        `(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 MONTH1 DAY1 and MONTH2 DAY2."
  (let ((decoded (cl-gensym))
        (target-month (cl-gensym))
        (target-day (cl-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, MONT-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, MONT-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, 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
         (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 period 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 day in the past to look at
default to `ledger-schedule-look-backward'
LOOK-FORWARD is the number of day in the futur 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)))
  (if (and file
           (file-exists-p file))
      (progn
        (ledger-schedule-create-auto-buffer
         (ledger-schedule-scan-transactions file)
         look-backward
         look-forward)
        (pop-to-buffer ledger-schedule-buffer-name))
    (error "Could not find ledger schedule file at %s" file)))


(provide 'ledger-schedule)

;;; ledger-schedule.el ends here