sfos/ledger
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Handle E and O for months and comma separate list of numbers for months and days.

Browse source
This commit is contained in:
Craig Earls 2014-11-26 12:15:38 -07:00
parent db7e4fd741
commit 8a826d9815
1 changed files with 31 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

98
lisp/ledger-schedule.el
View file

@ -131,10 +131,11 @@ For example every second Friday, regardless of month."
(defun ledger-schedule-is-holiday (date) (defun ledger-schedule-is-holiday (date)
"Return true if DATE is a holiday.") "Return true if DATE is a holiday."
nil)
(defun ledger-schedule-scan-transactions (schedule-file) (defun ledger-schedule-scan-transactions (schedule-file)
"Scans AUTO_FILE and returns a list of transactions with date predicates. "Scans SCHEDULE-FILE and returns a list of transactions with date predicates.
The car of each item is a function of date that returns true if The car of each item is a function of date that returns true if
the transaction should be logged for that day." the transaction should be logged for that day."
(interactive "fFile name: ") (interactive "fFile name: ")
@ -159,51 +160,8 @@ the transaction should be logged for that day."
(setq xact-list (cons transaction xact-list)))) (setq xact-list (cons transaction xact-list))))
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)))
(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) (defun ledger-schedule-read-descriptor-tree (descriptor-string)
"Take a date DESCRIPTOR-STRING and return a function of date that (ledger-schedule-transform-auto-tree (split-string (substring descriptor-string 1 -2) " ")))
returns true if the date meets the requirements"
(with-temp-buffer
;; copy the descriptor string into a temp buffer for manipulation
(let (pos)
;; Replace brackets with parens
(insert descriptor-string)
(ledger-schedule-replace-brackets)
(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 "\"" )))
;; read the descriptor string into a lisp object the transform the
;; string descriptor into usable things
(ledger-schedule-transform-auto-tree
(read (buffer-substring-no-properties (point-min) (point-max))))))
(defun ledger-schedule-transform-auto-tree (descriptor-string-list) (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." "Takes a lisp list of date descriptor strings, TREE, and returns a string with a lambda function of date."
@ -221,7 +179,7 @@ returns true if the date meets the requirements"
(push (ledger-schedule-compile-constraints newcar) result)) ) (push (ledger-schedule-compile-constraints newcar) result)) )
(setq descriptor-string-list (cdr descriptor-string-list))) (setq descriptor-string-list (cdr descriptor-string-list)))
;; tie up all the clauses in a big or and lambda, and return ;; tie up all the clauses in a big or lambda, and return
;; the lambda function as list to be executed by funcall ;; the lambda function as list to be executed by funcall
`(lambda (date) `(lambda (date)
,(nconc (list 'or) (nreverse result) descriptor-string-list))))) ,(nconc (list 'or) (nreverse result) descriptor-string-list)))))
@ -230,41 +188,40 @@ returns true if the date meets the requirements"
"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)) (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-year (ledger-schedule-constrain-year (nth 0 fields) (nth 1 fields) (nth 2 fields)))
(setq constrain-month (ledger-schedule-constrain-month (nth 1 fields))) (setq constrain-month (ledger-schedule-constrain-month (nth 0 fields) (nth 1 fields) (nth 2 fields)))
(setq constrain-day (ledger-schedule-constrain-day (nth 2 fields))) (setq constrain-day (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields)))
(list 'and constrain-year constrain-month constrain-day))) (list 'and constrain-year constrain-month constrain-day)))
(defun ledger-schedule-constrain-year (str) (defun ledger-schedule-constrain-year (year-desc month-desc day-desc)
(let ((year-match t)) (let ((year-match t))
(cond ((string= str "*") (cond ((string= year-desc "*")
year-match) year-match)
((/= 0 (setq year-match (string-to-number str))) ((/= 0 (setq year-match (string-to-number year-desc)))
`(eq (nth 5 (decode-time date)) ,year-match)) `(eq (nth 5 (decode-time date)) ,year-match))
(t (t
(error "Improperly specified year constraint: %s" str))))) (error "Improperly specified year constraint: %s %s %s" year-desc month-desc day-desc)))))
(defun ledger-schedule-constrain-month (str) (defun ledger-schedule-constrain-month (year-desc month-desc day-desc)
(cond ((string= month-desc "*")
(let ((month-match t)) t) ;; always match
(cond ((string= str "*") ((string= month-desc "E") ;; Even
month-match) ;; always match `(evenp (nth 4 (decode-time date))))
((/= 0 (setq month-match (string-to-number str))) ((string= month-desc "O") ;; Odd
(if (between month-match 1 12) ;; no month specified, assume 31 days. `(oddp (nth 4 (decode-time date))))
`(eq (nth 4 (decode-time date)) ,month-match) ((/= 0 (string-to-number month-desc)) ;; Starts with number
(error "ledger-schedule-constrain-numerical-month: month out of range %S" month-match))) `(memq (nth 4 (decode-time date)) ',(mapcar 'string-to-number (split-string month-desc ","))))
(t (t
(error "Improperly specified month constraint: %s" str))))) (error "Improperly specified month constraint: %s %s %s" year-desc month-desc day-desc))))
(defun ledger-schedule-constrain-day (str) (defun ledger-schedule-constrain-day (year-desc month-desc day-desc)
(let ((day-match t)) (cond ((string= day-desc "*")
(cond ((string= str "*")
t) t)
((/= 0 (setq day-match (string-to-number str))) ((/= 0 (string-to-number day-desc))
`(eq (nth 3 (decode-time date)) ,day-match)) `(memq (nth 3 (decode-time date)) ',(mapcar 'string-to-number (split-string day-desc ","))))
(t (t
(error "Improperly specified day constraint: %s" str))))) (error "Improperly specified day constraint: %s %s %s" year-desc month-desc day-desc))))
(defun ledger-schedule-parse-date-descriptor (descriptor) (defun ledger-schedule-parse-date-descriptor (descriptor)
"Parse the date descriptor, return the evaluator" "Parse the date descriptor, return the evaluator"
@ -282,6 +239,7 @@ returns true if the date meets the requirements"
items)) items))
(defun ledger-schedule-already-entered (candidate buffer) (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))) (let ((target-date (format-time-string date-format (car candidate)))
(target-payee (cadr candidate))) (target-payee (cadr candidate)))
nil)) nil))