diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/ledger-fontify.el | 20 | ||||
| -rw-r--r-- | lisp/ledger-schedule.el | 180 | ||||
| -rw-r--r-- | lisp/ledger-state.el | 6 |
3 files changed, 86 insertions, 120 deletions
diff --git a/lisp/ledger-fontify.el b/lisp/ledger-fontify.el index 309cbc3b..caf7690a 100644 --- a/lisp/ledger-fontify.el +++ b/lisp/ledger-fontify.el @@ -82,7 +82,7 @@ Fontify the first line of an xact" (let ((state nil)) (re-search-forward ledger-xact-start-regex) (ledger-fontify-set-face (list (match-beginning 1) (match-end 1)) 'ledger-font-posting-date-face) - (save-match-data (setq state (ledger-state-from-string (s-trim (match-string 5))))) + (save-match-data (setq state (ledger-state-from-string (match-string 5)))) (ledger-fontify-set-face (list (match-beginning 7) (match-end 7)) (cond ((eq state 'pending) 'ledger-font-payee-pending-face) @@ -113,7 +113,7 @@ Fontify the first line of an xact" ;; that took to figure out (re-search-forward " \\([*!]\\) " end t) (if (match-string 1) - (setq state (ledger-state-from-string (s-trim (match-string 1)))))) + (setq state (ledger-state-from-string (match-string 1))))) (beginning-of-line) (re-search-forward "[[:graph:]]\\([ \t][ \t]\\)" end 'end) ;; find the end of the account, or end of line @@ -191,20 +191,4 @@ Fontify the first line of an xact" (defun ledger-fontify-set-face (extents face) (put-text-property (car extents) (cadr extents) 'face face)) - -(defun s-trim-left (s) - "Remove whitespace at the beginning of S." - (if (string-match "\\`[ \t\n\r]+" s) - (replace-match "" t t s) - s)) - -(defun s-trim-right (s) - "Remove whitespace at the end of S." - (if (string-match "[ \t\n\r]+\\'" s) - (replace-match "" t t s) - s)) - -(defun s-trim (s) - "Remove whitespace at the beginning and end of S." - (s-trim-left (s-trim-right s))) ;;; ledger-fontify.el ends here diff --git a/lisp/ledger-schedule.el b/lisp/ledger-schedule.el index 9c41c63d..a5e7decb 100644 --- a/lisp/ledger-schedule.el +++ b/lisp/ledger-schedule.el @@ -74,6 +74,15 @@ If year is nil, assume it is not a leap year" (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" + (cond ((string= day-string "Su") 7) + ((string= day-string "Mo") 1) + ((string= day-string "Tu") 2) + ((string= day-string "We") 3) + ((string= day-string "Th") 4) + ((string= day-string "Fr") 5) + ((string= day-string "Sa") 6))) ;; Macros to handle date expressions (defun ledger-schedule-constrain-day-in-month (count day-of-week) @@ -111,9 +120,9 @@ COUNT 0) means EVERY day-of-week (eg. every Saturday)" (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))))) + (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 (eval start-date))) ,(* skip 7))) + `(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) @@ -131,10 +140,11 @@ For example every second Friday, regardless of month." (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) - "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 transaction should be logged for that day." (interactive "fFile name: ") @@ -159,51 +169,8 @@ the transaction should be logged for that day." (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))) - -(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 of date that -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)))))) + (ledger-schedule-transform-auto-tree (split-string (substring descriptor-string 1 (string-match "]" descriptor-string)) " "))) (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." @@ -221,67 +188,82 @@ returns true if the date meets the requirements" (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 + ;; 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)) - 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))) - - (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: %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))))) - -(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))))) - -(defun ledger-schedule-parse-date-descriptor (descriptor) - "Parse the date descriptor, return the evaluator" - (ledger-schedule-compile-constraints descriptor)) + (let ((fields (split-string descriptor-string "[/\\-]" t))) + (if (string-match "[A-Za-z]" descriptor-string) + (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields)) + (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) + (cond ((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) + (cond ((string= month-desc "*") + t) ;; always match + ((string= month-desc "E") ;; Even + `(evenp (nth 4 (decode-time date)))) + ((string= month-desc "O") ;; Odd + `(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) + (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) + (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) - (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)) + "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) + (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-already-entered (candidate buffer) + "return TRUE if CANDIDATE is already in BUFFER" (let ((target-date (format-time-string date-format (car candidate))) (target-payee (cadr candidate))) nil)) diff --git a/lisp/ledger-state.el b/lisp/ledger-state.el index 8822570d..b2574b10 100644 --- a/lisp/ledger-state.el +++ b/lisp/ledger-state.el @@ -68,9 +68,9 @@ (defun ledger-state-from-string (state-string) "Get state from STATE-CHAR." - (cond ((string= state-string "!") 'pending) - ((string= state-string "*") 'cleared) - ((string= state-string ";") 'comment) + (cond ((string-match "\\!" state-string) 'pending) + ((string-match "\\*" state-string) 'cleared) + ((string-match ";" state-string) 'comment) (t nil))) (defun ledger-toggle-current-posting (&optional style) |