summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ldg-mode.el12
-rw-r--r--lisp/ldg-new.el2
-rw-r--r--lisp/ldg-schedule.el195
3 files changed, 104 insertions, 105 deletions
diff --git a/lisp/ldg-mode.el b/lisp/ldg-mode.el
index cf0f56e7..f0af4383 100644
--- a/lisp/ldg-mode.el
+++ b/lisp/ldg-mode.el
@@ -106,18 +106,20 @@ Can be pcomplete, or align-posting"
(define-key map [(control ?c) (control ?r)] 'ledger-reconcile)
(define-key map [(control ?c) (control ?s)] 'ledger-sort-region)
(define-key map [(control ?c) (control ?t)] 'ledger-insert-effective-date)
+ (define-key map [(control ?c) (control ?u)] 'ledger-schedule-upcoming)
(define-key map [(control ?c) (control ?y)] 'ledger-set-year)
- (define-key map [tab] 'ledger-magic-tab)
+ (define-key map [tab] 'ledger-magic-tab)
(define-key map [(control ?i)] 'ledger-magic-tab)
(define-key map [(control ?c) tab] 'ledger-fully-complete-entry)
(define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-entry)
- (define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report)
- (define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto)
+
(define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo)
- (define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save)
(define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit)
+ (define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto)
(define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill)
-
+ (define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report)
+ (define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save)
+
(define-key map [(meta ?p)] 'ledger-post-prev-xact)
(define-key map [(meta ?n)] 'ledger-post-next-xact)
diff --git a/lisp/ldg-new.el b/lisp/ldg-new.el
index 05e18818..b018d217 100644
--- a/lisp/ldg-new.el
+++ b/lisp/ldg-new.el
@@ -50,7 +50,7 @@
(require 'ldg-test)
(require 'ldg-texi)
(require 'ldg-xact)
-
+(require 'ldg-schedule)
;;; Code:
diff --git a/lisp/ldg-schedule.el b/lisp/ldg-schedule.el
index effa20b5..885c0876 100644
--- a/lisp/ldg-schedule.el
+++ b/lisp/ldg-schedule.el
@@ -68,7 +68,7 @@ If year is nil, assume it is not a leap year"
;; Macros to handle date expressions
-(defmacro ledger-schedule-constrain-day-in-month-macro (count day-of-week)
+(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.
For example, return true if date is the 3rd Thursday of the
month. Negative COUNT starts from the end of the month. (EQ
@@ -79,12 +79,10 @@ COUNT 0) means EVERY day-of-week (eg. every Saturday)"
((> count 0) ;; Positive count
(let ((decoded (gensym)))
`(let ((,decoded (decode-time date)))
- (if (and (eq (nth 6 ,decoded) ,day-of-week)
- (between (nth 3 ,decoded)
- ,(* (1- count) 7)
- ,(* count 7)))
- t
- nil))))
+ (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)))
@@ -92,53 +90,25 @@ COUNT 0) means EVERY day-of-week (eg. every Saturday)"
(,days-in-month (ledger-schedule-days-in-month
(nth 4 ,decoded)
(nth 5 ,decoded))))
- (if (and (eq (nth 6 ,decoded) ,day-of-week)
- (between (nth 3 ,decoded)
- (+ ,days-in-month ,(* count 7))
- (+ ,days-in-month ,(* (1+ count) 7))))
- t
- nil))))
+ (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)))
-(defmacro ledger-schedule-constrain-numerical-date-macro (year month day)
- "Return a function of date that is only true if all constraints are met.
-A nil constraint matches any input, a numerical entry must match that field
-of date."
- ;; Do bounds checking to make sure the incoming date constraint is sane
- (if
- (if (eval month) ;; if we have a month
- (and (between (eval month) 1 12) ;; make sure it is between 1
- ;; and twelve and the number
- ;; of days are ok
- (between (eval day) 1 (ledger-schedule-days-in-month (eval month) (eval year))))
- (between (eval day) 1 31)) ;; no month specified, assume 31 days.
- `'(and ,(if (eval year)
- `(if (eq (nth 5 (decode-time date)) ,(eval year)) t)
- `t)
- ,(if (eval month)
- `(if (eq (nth 4 (decode-time date)) ,(eval month)) t)
- `t)
- ,(if (eval day)
- `(if (eq (nth 3 (decode-time date)) ,(eval day)) t)))
- (error "ledger-schedule-constraint-numerical-date-macro: date out of range %S %S %S" (eval year) (eval month) (eval day))))
-
-
-
-(defmacro ledger-schedule-constrain-every-count-day-macro (day-of-week skip start-date)
+(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
- `(if (zerop (mod (- (time-to-days date) ,(time-to-days (eval start-date))) ,(* skip 7)))
- t
- nil)
- (error "START-DATE day of week doesn't match DAY-OF-WEEK"))))
+ `(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"))))
-(defmacro ledger-schedule-constrain-date-range-macro (month1 day1 month2 day2)
+(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))
@@ -190,8 +160,21 @@ the transaction should be logged for that day."
(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\\)\\)\\)\\)"))
+
(defun ledger-schedule-read-descriptor-tree (descriptor-string)
- "Take a date descriptor string and return a function that
+ "Take a date DESCRIPTOR-STRING and return a function of date that
returns true if the date meets the requirements"
(with-temp-buffer
;; copy the descriptor string into a temp buffer for manipulation
@@ -202,18 +185,7 @@ 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
- (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\\)\\)\\)\\)") nil t) ;; Day slot
+ (while (re-search-backward ledger-schedule-descriptor-regex nil t) ;; Day slot
(goto-char
(match-end 0))
(insert ?\")
@@ -222,61 +194,73 @@ returns true if the date meets the requirements"
;; read the descriptor string into a lisp object the transform the
;; string descriptor into useable things
- (ledger-transform-auto-tree
+ (ledger-schedule-transform-auto-tree
(read (buffer-substring-no-properties (point-min) (point-max))))))
-(defun ledger-transform-auto-tree (tree)
+(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
- (if (consp tree)
+ (if (consp descriptor-string-list)
(let (result)
- (while (consp tree)
- (let ((newcar (car tree)))
+ (while (consp descriptor-string-list)
+ (let ((newcar (car descriptor-string-list)))
(if (consp newcar)
- (setq newcar (ledger-transform-auto-tree (car tree))))
+ (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)
- (push (ledger-schedule-parse-date-descriptor newcar) result)) )
- (setq tree (cdr tree)))
+ ;; 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
+ ;; 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) tree)))))
+ ,(nconc (list 'or) (nreverse result) descriptor-string-list)))))
-(defun ledger-schedule-split-constraints (descriptor-string)
+(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)
- (if (string= (car fields) "*")
- (setq constrain-year nil)
- (setq constrain-year (car fields)))
- (if (string= (cadr fields) "*")
- (setq constrain-month nil)
- (setq constrain-month (cadr fields)))
- (if (string= (nth 2 fields) "*")
- (setq constrain-day nil)
- (setq constrain-day (nth 2 fields)))
- (list constrain-year constrain-month constrain-day)))
-
-(defun ledger-string-to-number-or-nil (str)
- (if str
- (string-to-number str)
- nil))
-
-(defun ledger-schedule-compile-constraints (constraint-list)
- (let ((year-constraint (ledger-string-to-number-or-nil (nth 0 constraint-list)))
- (month-constraint (ledger-string-to-number-or-nil (nth 1 constraint-list)))
- (day-constraint (ledger-string-to-number-or-nil (nth 2 constraint-list))))
- (ledger-schedule-constrain-numerical-date-macro
- year-constraint
- month-constraint
- day-constraint)))
+ (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)))
+
+ (list 'and constrain-year constrain-month constrain-day)))
+
+(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: " 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: " 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: " str)))))
(defun ledger-schedule-parse-date-descriptor (descriptor)
"Parse the date descriptor, return the evaluator"
- (ledger-schedule-compile-constraints
- (ledger-schedule-split-constraints descriptor)))
-
+ (ledger-schedule-compile-constraints descriptor))
(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"
@@ -303,7 +287,9 @@ returns true if the date meets the requirements"
(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"))))))
+ (insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n")))
+ (ledger-mode))
+ (length candidates)))
;;
@@ -311,9 +297,12 @@ returns true if the date meets the requirements"
;;
(defvar auto-items)
-(defun ledger-schedule-test-setup ()
- (setq auto-items
- (ledger-schedule-scan-transactions ledger-schedule-file)))
+(defun ledger-schedule-test ( early horizon)
+ (ledger-schedule-create-auto-buffer
+ (ledger-schedule-scan-transactions ledger-schedule-file)
+ early
+ horizon
+ (get-buffer "2013.ledger")))
(defun ledger-schedule-test-predict ()
@@ -322,12 +311,20 @@ returns true if the date meets the requirements"
(loop for day from 0 to ledger-schedule-look-forward by 1 do
(setq test-date (time-add today (days-to-time day)))
- ;;(message "date: %S" (decode-time test-date))
(dolist (item auto-items items)
(if (funcall (car item) test-date)
(setq items (append items (list (decode-time test-date) (cdr item)))))))
items))
+(defun ledger-schedule-upcoming ()
+ (interactive)
+ (ledger-schedule-create-auto-buffer
+ (ledger-schedule-scan-transactions ledger-schedule-file)
+ ledger-schedule-look-backward
+ ledger-schedule-look-forward
+ (current-buffer)))
+
+
(provide 'ldg-schedule)
;;; ldg-schedule.el ends here
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-07 19:56:51 +0000