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

Dramatic improvements to account completion speeds.

Browse source
This commit is contained in:
Craig Earls 2013-06-05 16:41:11 -07:00
parent e0b02afd60
commit 7540647f01
4 changed files with 222 additions and 234 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

100
lisp/ldg-complete.el
View file

@ -34,8 +34,8 @@
;; with pcomplete. See pcomplete-parse-arguments-function for ;; with pcomplete. See pcomplete-parse-arguments-function for
;; details ;; details
(let* ((begin (save-excursion (let* ((begin (save-excursion
(ledger-thing-at-point) ;; leave point at beginning of thing under point (ledger-thing-at-point) ;; leave point at beginning of thing under point
(point))) (point)))
(end (point)) (end (point))
begins args) begins args)
;; to support end of line metadata ;; to support end of line metadata
@ -65,8 +65,8 @@
(unless (and (>= origin (match-beginning 0)) (unless (and (>= origin (match-beginning 0))
(< origin (match-end 0))) (< origin (match-end 0)))
(setq payees-list (cons (match-string-no-properties 3) (setq payees-list (cons (match-string-no-properties 3)
payees-list))))) ;; add the payee payees-list))))) ;; add the payee
;; to the list ;; to the list
(pcomplete-uniqify-list (nreverse payees-list)))) (pcomplete-uniqify-list (nreverse payees-list))))
@ -75,14 +75,16 @@
(let ((origin (point)) (let ((origin (point))
accounts accounts
(account-tree (list t)) (account-tree (list t))
(account-elements nil)) (account-elements nil)
(seed-regex (ledger-account-any-status-with-seed-regex
(regexp-quote (car pcomplete-args)))))
(save-excursion (save-excursion
(goto-char (point-min)) (goto-char (point-min))
(dolist (account (dolist (account
(delete-dups (delete-dups
(progn (progn
(while (re-search-forward ledger-account-any-status-regex nil t) (while (re-search-forward seed-regex nil t)
(unless (between origin (match-beginning 0) (match-end 0)) (unless (between origin (match-beginning 0) (match-end 0))
(setq accounts (cons (match-string-no-properties 2) accounts)))) (setq accounts (cons (match-string-no-properties 2) accounts))))
accounts))) accounts)))
@ -127,19 +129,19 @@ Return list."
(setq prefix (concat prefix (and prefix ":") (setq prefix (concat prefix (and prefix ":")
(car elements)) (car elements))
root (cdr xact)) root (cdr xact))
(setq root nil elements nil))) (setq root nil elements nil)))
(setq elements (cdr elements))) (setq elements (cdr elements)))
(setq root (delete (list (car elements) t) root)) (setq root (delete (list (car elements) t) root))
(and root (and root
(sort (sort
(mapcar (function (mapcar (function
(lambda (x) (lambda (x)
(let ((term (if prefix (let ((term (if prefix
(concat prefix ":" (car x)) (concat prefix ":" (car x))
(car x)))) (car x))))
(if (> (length (cdr x)) 1) (if (> (length (cdr x)) 1)
(concat term ":") (concat term ":")
term)))) term))))
(cdr root)) (cdr root))
'string-lessp)))) 'string-lessp))))
@ -153,21 +155,21 @@ Return list."
(delete (delete
(caar (ledger-parse-arguments)) (caar (ledger-parse-arguments))
(ledger-payees-in-buffer)) ;; this completes against payee names (ledger-payees-in-buffer)) ;; this completes against payee names
(progn (progn
(let ((text (buffer-substring-no-properties (let ((text (buffer-substring-no-properties
(line-beginning-position) (line-beginning-position)
(line-end-position)))) (line-end-position))))
(delete-region (line-beginning-position) (delete-region (line-beginning-position)
(line-end-position)) (line-end-position))
(condition-case nil (condition-case nil
(ledger-add-transaction text t) (ledger-add-transaction text t)
(error nil))) (error nil)))
(forward-line) (forward-line)
(goto-char (line-end-position)) (goto-char (line-end-position))
(search-backward ";" (line-beginning-position) t) (search-backward ";" (line-beginning-position) t)
(skip-chars-backward " \t0123456789.,") (skip-chars-backward " \t0123456789.,")
(throw 'pcompleted t))) (throw 'pcompleted t)))
(ledger-accounts))))) (ledger-accounts)))))
(defun ledger-fully-complete-xact () (defun ledger-fully-complete-xact ()
"Completes a transaction if there is another matching payee in the buffer. "Completes a transaction if there is another matching payee in the buffer.
@ -225,30 +227,30 @@ ledger-magic-tab would cycle properly"
(push (car (last pcomplete-current-completions)) (push (car (last pcomplete-current-completions))
pcomplete-current-completions) pcomplete-current-completions)
(setcdr (last pcomplete-current-completions 2) nil)) (setcdr (last pcomplete-current-completions 2) nil))
(nconc pcomplete-current-completions (nconc pcomplete-current-completions
(list (car pcomplete-current-completions))) (list (car pcomplete-current-completions)))
(setq pcomplete-current-completions (setq pcomplete-current-completions
(cdr pcomplete-current-completions))) (cdr pcomplete-current-completions)))
(pcomplete-insert-entry pcomplete-last-completion-stub (pcomplete-insert-entry pcomplete-last-completion-stub
(car pcomplete-current-completions) (car pcomplete-current-completions)
nil pcomplete-last-completion-raw)) nil pcomplete-last-completion-raw))
(setq pcomplete-current-completions nil (setq pcomplete-current-completions nil
pcomplete-last-completion-raw nil) pcomplete-last-completion-raw nil)
(catch 'pcompleted (catch 'pcompleted
(let* ((pcomplete-stub) (let* ((pcomplete-stub)
pcomplete-seen pcomplete-norm-func pcomplete-seen pcomplete-norm-func
pcomplete-args pcomplete-last pcomplete-index pcomplete-args pcomplete-last pcomplete-index
(pcomplete-autolist pcomplete-autolist) (pcomplete-autolist pcomplete-autolist)
(pcomplete-suffix-list pcomplete-suffix-list) (pcomplete-suffix-list pcomplete-suffix-list)
(completions (pcomplete-completions)) (completions (pcomplete-completions))
(result (pcomplete-do-complete pcomplete-stub completions))) (result (pcomplete-do-complete pcomplete-stub completions)))
(and result (and result
(not (eq (car result) 'listed)) (not (eq (car result) 'listed))
(cdr result) (cdr result)
(pcomplete-insert-entry pcomplete-stub (cdr result) (pcomplete-insert-entry pcomplete-stub (cdr result)
(memq (car result) (memq (car result)
'(sole shortest)) '(sole shortest))
pcomplete-last-completion-raw)))))) pcomplete-last-completion-raw))))))
(provide 'ldg-complete) (provide 'ldg-complete)

220
lisp/ldg-mode.el
View file

@ -41,31 +41,31 @@
(defun ledger-read-account-with-prompt (prompt) (defun ledger-read-account-with-prompt (prompt)
(let* ((context (ledger-context-at-point)) (let* ((context (ledger-context-at-point))
(default (if (and (eq (ledger-context-line-type context) 'acct-transaction) (default (if (and (eq (ledger-context-line-type context) 'acct-transaction)
(eq (ledger-context-current-field context) 'account)) (eq (ledger-context-current-field context) 'account))
(regexp-quote (ledger-context-field-value context 'account)) (regexp-quote (ledger-context-field-value context 'account))
nil))) nil)))
(ledger-read-string-with-default prompt default))) (ledger-read-string-with-default prompt default)))
(defun ledger-read-string-with-default (prompt default) (defun ledger-read-string-with-default (prompt default)
"Return user supplied string after PROMPT, or DEFAULT." "Return user supplied string after PROMPT, or DEFAULT."
(read-string (concat prompt (read-string (concat prompt
(if default (if default
(concat " (" default "): ") (concat " (" default "): ")
": ")) ": "))
nil 'ledger-minibuffer-history default)) nil 'ledger-minibuffer-history default))
(defun ledger-display-balance-at-point () (defun ledger-display-balance-at-point ()
"Display the cleared-or-pending balance. "Display the cleared-or-pending balance.
And calculate the target-delta of the account being reconciled." And calculate the target-delta of the account being reconciled."
(interactive) (interactive)
(let* ((account (ledger-read-account-with-prompt "Account balance to show")) (let* ((account (ledger-read-account-with-prompt "Account balance to show"))
(buffer (current-buffer)) (buffer (current-buffer))
(balance (with-temp-buffer (balance (with-temp-buffer
(ledger-exec-ledger buffer (current-buffer) "cleared" account) (ledger-exec-ledger buffer (current-buffer) "cleared" account)
(if (> (buffer-size) 0) (if (> (buffer-size) 0)
(buffer-substring-no-properties (point-min) (1- (point-max))) (buffer-substring-no-properties (point-min) (1- (point-max)))
(concat account " is empty."))))) (concat account " is empty.")))))
(when balance (when balance
(message balance)))) (message balance))))
@ -96,117 +96,117 @@ Can indent, complete or align depending on context."
(defun ledger-insert-effective-date () (defun ledger-insert-effective-date ()
(interactive) (interactive)
(let ((context (car (ledger-context-at-point))) (let ((context (car (ledger-context-at-point)))
(date-string (format-time-string (cdr (assoc "date-format" ledger-environment-alist))))) (date-string (format-time-string (cdr (assoc "date-format" ledger-environment-alist)))))
(cond ((eq 'xact context) (cond ((eq 'xact context)
(beginning-of-line) (beginning-of-line)
(insert date-string "=")) (insert date-string "="))
((eq 'acct-transaction context) ((eq 'acct-transaction context)
(end-of-line) (end-of-line)
(insert " ; [=" date-string "]"))))) (insert " ; [=" date-string "]")))))
;;;###autoload ;;;###autoload
(define-derived-mode ledger-mode text-mode "Ledger" (define-derived-mode ledger-mode text-mode "Ledger"
"A mode for editing ledger data files." "A mode for editing ledger data files."
(ledger-check-version) (ledger-check-version)
(ledger-post-setup) (ledger-post-setup)
(set (make-local-variable 'comment-start) " ; ") (set (make-local-variable 'comment-start) " ; ")
(set (make-local-variable 'comment-end) "") (set (make-local-variable 'comment-end) "")
(set (make-local-variable 'indent-tabs-mode) nil) (set (make-local-variable 'indent-tabs-mode) nil)
(if (boundp 'font-lock-defaults) (if (boundp 'font-lock-defaults)
(set (make-local-variable 'font-lock-defaults) (set (make-local-variable 'font-lock-defaults)
'(ledger-font-lock-keywords nil t))) '(ledger-font-lock-keywords nil t)))
(setq font-lock-extend-region-functions (setq font-lock-extend-region-functions
(list #'font-lock-extend-region-wholelines)) (list #'font-lock-extend-region-wholelines))
(setq font-lock-multiline nil) (setq font-lock-multiline nil)
(set (make-local-variable 'pcomplete-parse-arguments-function) (set (make-local-variable 'pcomplete-parse-arguments-function)
'ledger-parse-arguments) 'ledger-parse-arguments)
(set (make-local-variable 'pcomplete-command-completion-function) (set (make-local-variable 'pcomplete-command-completion-function)
'ledger-complete-at-point) 'ledger-complete-at-point)
(set (make-local-variable 'pcomplete-termination-string) "") (set (make-local-variable 'pcomplete-termination-string) "")
(add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t) (add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t)
(add-hook 'before-revert-hook 'ledger-occur-remove-all-overlays nil t) (add-hook 'before-revert-hook 'ledger-occur-remove-all-overlays nil t)
(make-variable-buffer-local 'highlight-overlay) (make-variable-buffer-local 'highlight-overlay)
(ledger-init-load-init-file) (ledger-init-load-init-file)
(set (make-local-variable 'indent-region-function) 'ledger-post-align-postings) (set (make-local-variable 'indent-region-function) 'ledger-post-align-postings)
(let ((map (current-local-map))) (let ((map (current-local-map)))
(define-key map [(control ?c) (control ?a)] 'ledger-add-transaction) (define-key map [(control ?c) (control ?a)] 'ledger-add-transaction)
(define-key map [(control ?c) (control ?b)] 'ledger-post-edit-amount) (define-key map [(control ?c) (control ?b)] 'ledger-post-edit-amount)
(define-key map [(control ?c) (control ?c)] 'ledger-toggle-current) (define-key map [(control ?c) (control ?c)] 'ledger-toggle-current)
(define-key map [(control ?c) (control ?d)] 'ledger-delete-current-transaction) (define-key map [(control ?c) (control ?d)] 'ledger-delete-current-transaction)
(define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-transaction) (define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-transaction)
(define-key map [(control ?c) (control ?f)] 'ledger-occur) (define-key map [(control ?c) (control ?f)] 'ledger-occur)
(define-key map [(control ?c) (control ?k)] 'ledger-copy-transaction-at-point) (define-key map [(control ?c) (control ?k)] 'ledger-copy-transaction-at-point)
(define-key map [(control ?c) (control ?m)] 'ledger-set-month) (define-key map [(control ?c) (control ?m)] 'ledger-set-month)
(define-key map [(control ?c) (control ?r)] 'ledger-reconcile) (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 ?s)] 'ledger-sort-region)
(define-key map [(control ?c) (control ?t)] 'ledger-insert-effective-date) (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 ?u)] 'ledger-schedule-upcoming)
(define-key map [(control ?c) (control ?y)] 'ledger-set-year) (define-key map [(control ?c) (control ?y)] 'ledger-set-year)
(define-key map [(control ?c) (control ?p)] 'ledger-display-balance-at-point) (define-key map [(control ?c) (control ?p)] 'ledger-display-balance-at-point)
(define-key map [(control ?c) (control ?l)] 'ledger-display-ledger-stats) (define-key map [(control ?c) (control ?l)] 'ledger-display-ledger-stats)
(define-key map [tab] 'ledger-magic-tab) (define-key map [tab] 'ledger-magic-tab)
(define-key map [(control tab)] 'ledger-post-align-xact) (define-key map [(control tab)] 'ledger-post-align-xact)
(define-key map [(control ?i)] 'ledger-magic-tab) (define-key map [(control ?i)] 'ledger-magic-tab)
(define-key map [(control ?c) tab] 'ledger-fully-complete-xact) (define-key map [(control ?c) tab] 'ledger-fully-complete-xact)
(define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-xact) (define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-xact)
(define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo) (define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo)
(define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit) (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 ?g)] 'ledger-report-goto)
(define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill) (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 ?r)] 'ledger-report)
(define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save) (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 ?p)] 'ledger-post-prev-xact)
(define-key map [(meta ?n)] 'ledger-post-next-xact) (define-key map [(meta ?n)] 'ledger-post-next-xact)
(define-key map [menu-bar] (make-sparse-keymap "ldg-menu")) (define-key map [menu-bar] (make-sparse-keymap "ldg-menu"))
(define-key map [menu-bar ldg-menu] (cons "Ledger" map)) (define-key map [menu-bar ldg-menu] (cons "Ledger" map))
(define-key map [report-kill] '(menu-item "Kill Report" ledger-report-kill :enable ledger-works)) (define-key map [report-kill] '(menu-item "Kill Report" ledger-report-kill :enable ledger-works))
(define-key map [report-edit] '(menu-item "Edit Report" ledger-report-edit :enable ledger-works)) (define-key map [report-edit] '(menu-item "Edit Report" ledger-report-edit :enable ledger-works))
(define-key map [report-save] '(menu-item "Save Report" ledger-report-save :enable ledger-works)) (define-key map [report-save] '(menu-item "Save Report" ledger-report-save :enable ledger-works))
(define-key map [report-rrun] '(menu-item "Re-run Report" ledger-report-redo :enable ledger-works)) (define-key map [report-rrun] '(menu-item "Re-run Report" ledger-report-redo :enable ledger-works))
(define-key map [report-goto] '(menu-item "Goto Report" ledger-report-goto :enable ledger-works)) (define-key map [report-goto] '(menu-item "Goto Report" ledger-report-goto :enable ledger-works))
(define-key map [report-run] '(menu-item "Run Report" ledger-report :enable ledger-works)) (define-key map [report-run] '(menu-item "Run Report" ledger-report :enable ledger-works))
(define-key map [sep5] '(menu-item "--")) (define-key map [sep5] '(menu-item "--"))
(define-key map [set-month] '(menu-item "Set Month" ledger-set-month :enable ledger-works)) (define-key map [set-month] '(menu-item "Set Month" ledger-set-month :enable ledger-works))
(define-key map [set-year] '(menu-item "Set Year" ledger-set-year :enable ledger-works)) (define-key map [set-year] '(menu-item "Set Year" ledger-set-year :enable ledger-works))
(define-key map [cust] '(menu-item "Customize Ledger Mode" (lambda () (define-key map [cust] '(menu-item "Customize Ledger Mode" (lambda ()
(interactive) (interactive)
(customize-group 'ledger)))) (customize-group 'ledger))))
(define-key map [sep1] '("--")) (define-key map [sep1] '("--"))
(define-key map [effective-date] '(menu-item "Set effective date" ledger-insert-effective-date)) (define-key map [effective-date] '(menu-item "Set effective date" ledger-insert-effective-date))
(define-key map [sort-end] '(menu-item "Mark Sort End" ledger-sort-insert-end-mark)) (define-key map [sort-end] '(menu-item "Mark Sort End" ledger-sort-insert-end-mark))
(define-key map [sort-start] '(menu-item "Mark Sort Beginning" ledger-sort-insert-start-mark)) (define-key map [sort-start] '(menu-item "Mark Sort Beginning" ledger-sort-insert-start-mark))
(define-key map [sort-buff] '(menu-item "Sort Buffer" ledger-sort-buffer)) (define-key map [sort-buff] '(menu-item "Sort Buffer" ledger-sort-buffer))
(define-key map [sort-reg] '(menu-item "Sort Region" ledger-sort-region :enable mark-active)) (define-key map [sort-reg] '(menu-item "Sort Region" ledger-sort-region :enable mark-active))
(define-key map [align-xact] '(menu-item "Align Xact" ledger-post-align-xact)) (define-key map [align-xact] '(menu-item "Align Xact" ledger-post-align-xact))
(define-key map [align-reg] '(menu-item "Align Region" ledger-post-align-postings :enable mark-active)) (define-key map [align-reg] '(menu-item "Align Region" ledger-post-align-postings :enable mark-active))
(define-key map [sep2] '(menu-item "--")) (define-key map [sep2] '(menu-item "--"))
(define-key map [copy-xact] '(menu-item "Copy Trans at Point" ledger-copy-transaction-at-point)) (define-key map [copy-xact] '(menu-item "Copy Trans at Point" ledger-copy-transaction-at-point))
(define-key map [toggle-post] '(menu-item "Toggle Current Posting" ledger-toggle-current)) (define-key map [toggle-post] '(menu-item "Toggle Current Posting" ledger-toggle-current))
(define-key map [toggle-xact] '(menu-item "Toggle Current Transaction" ledger-toggle-current-transaction)) (define-key map [toggle-xact] '(menu-item "Toggle Current Transaction" ledger-toggle-current-transaction))
(define-key map [sep4] '(menu-item "--")) (define-key map [sep4] '(menu-item "--"))
(define-key map [recon-account] '(menu-item "Reconcile Account" ledger-reconcile :enable ledger-works)) (define-key map [recon-account] '(menu-item "Reconcile Account" ledger-reconcile :enable ledger-works))
(define-key map [check-balance] '(menu-item "Check Balance" ledger-display-balance-at-point :enable ledger-works)) (define-key map [check-balance] '(menu-item "Check Balance" ledger-display-balance-at-point :enable ledger-works))
(define-key map [sep6] '(menu-item "--")) (define-key map [sep6] '(menu-item "--"))
(define-key map [edit-amount] '(menu-item "Calc on Amount" ledger-post-edit-amount)) (define-key map [edit-amount] '(menu-item "Calc on Amount" ledger-post-edit-amount))
(define-key map [sep] '(menu-item "--")) (define-key map [sep] '(menu-item "--"))
(define-key map [delete-xact] '(menu-item "Delete Transaction" ledger-delete-current-transaction)) (define-key map [delete-xact] '(menu-item "Delete Transaction" ledger-delete-current-transaction))
(define-key map [cmp-xact] '(menu-item "Complete Transaction" ledger-fully-complete-xact)) (define-key map [cmp-xact] '(menu-item "Complete Transaction" ledger-fully-complete-xact))
(define-key map [add-xact] '(menu-item "Add Transaction (ledger xact)" ledger-add-transaction :enable ledger-works)) (define-key map [add-xact] '(menu-item "Add Transaction (ledger xact)" ledger-add-transaction :enable ledger-works))
(define-key map [sep3] '(menu-item "--")) (define-key map [sep3] '(menu-item "--"))
(define-key map [stats] '(menu-item "Ledger Statistics" ledger-display-ledger-stats :enable ledger-works)) (define-key map [stats] '(menu-item "Ledger Statistics" ledger-display-ledger-stats :enable ledger-works))
(define-key map [fold-buffer] '(menu-item "Narrow to REGEX" ledger-occur)))) (define-key map [fold-buffer] '(menu-item "Narrow to REGEX" ledger-occur))))

127
lisp/ldg-occur.el
View file

@ -39,7 +39,7 @@
(defvar ledger-occur-mode nil (defvar ledger-occur-mode nil
"name of the minor mode, shown in the mode-line") "name of the minor mode, shown in the mode-line")
(make-variable-buffer-local 'ledger-occur-mode) (make-variable-buffer-local 'ledger-occur-mode)
@ -49,16 +49,11 @@
(defvar ledger-occur-history nil (defvar ledger-occur-history nil
"History of previously searched expressions for the prompt.") "History of previously searched expressions for the prompt.")
;;(make-variable-buffer-local 'ledger-occur-history)
(defvar ledger-occur-last-match nil (defvar ledger-occur-last-match nil
"Last match found.") "Last match found.")
(make-variable-buffer-local 'ledger-occur-last-match) (make-variable-buffer-local 'ledger-occur-last-match)
(defvar ledger-occur-overlay-list nil
"A list of currently active overlays to the ledger buffer.")
(make-variable-buffer-local 'ledger-occur-overlay-list)
(defun ledger-occur-remove-all-overlays () (defun ledger-occur-remove-all-overlays ()
"Remove all overlays from the ledger buffer." "Remove all overlays from the ledger buffer."
(interactive) (interactive)
@ -70,21 +65,19 @@
When REGEX is nil, unhide everything, and remove higlight" When REGEX is nil, unhide everything, and remove higlight"
(set-buffer buffer) (set-buffer buffer)
(setq ledger-occur-mode (setq ledger-occur-mode
(if (or (null regex) (if (or (null regex)
(zerop (length regex))) (zerop (length regex)))
nil nil
(concat " Ledger-Narrowed: " regex))) (concat " Ledger-Narrowed: " regex)))
(force-mode-line-update) (force-mode-line-update)
(ledger-occur-remove-overlays) (ledger-occur-remove-overlays)
(if ledger-occur-mode (when ledger-occur-mode
(let* ((buffer-matches (ledger-occur-find-matches regex)) (ledger-occur-create-overlays
(ovl-bounds (ledger-occur-create-xact-overlay-bounds buffer-matches))) (ledger-occur-compress-matches
(setq ledger-occur-overlay-list (ledger-occur-find-matches regex)))
(append (ledger-occur-create-xact-overlays ovl-bounds) (setq ledger-occur-last-match regex)
(ledger-occur-create-narrowed-overlays buffer-matches))) (if (get-buffer-window buffer)
(setq ledger-occur-last-match regex) (select-window (get-buffer-window buffer))))
(if (get-buffer-window buffer)
(select-window (get-buffer-window buffer)))))
(recenter)) (recenter))
(defun ledger-occur (regex) (defun ledger-occur (regex)
@ -97,7 +90,7 @@ When REGEX is nil, unhide everything, and remove higlight"
(if ledger-occur-mode (if ledger-occur-mode
(list nil) (list nil)
(list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ") (list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ")
nil 'ledger-occur-history (ledger-occur-prompt))))) nil 'ledger-occur-history (ledger-occur-prompt)))))
(ledger-occur-mode regex (current-buffer))) (ledger-occur-mode regex (current-buffer)))
(defun ledger-occur-prompt () (defun ledger-occur-prompt ()
@ -115,41 +108,32 @@ When REGEX is nil, unhide everything, and remove higlight"
(if (= (line-number-at-pos pos1) (if (= (line-number-at-pos pos1)
(line-number-at-pos pos2)) (line-number-at-pos pos2))
(buffer-substring-no-properties pos1 pos2))) (buffer-substring-no-properties pos1 pos2)))
(current-word)))) (current-word))))
prompt)) prompt))
(defun ledger-occur-create-narrowed-overlays(buffer-matches)
(if buffer-matches
(let ((overlays
(let ((prev-end (point-min)))
(mapcar (lambda (match)
(prog1
(make-overlay prev-end (car match)
(current-buffer) t nil)
(setq prev-end (1+ (cadr match)))))
buffer-matches))))
(mapcar (lambda (ovl)
(overlay-put ovl ledger-occur-overlay-property-name t)
(overlay-put ovl 'invisible t))
(push (make-overlay (cadr (car(last buffer-matches)))
(point-max)
(current-buffer) t nil) overlays)))))
(defun ledger-occur-make-visible-overlay (beg end)
(let ((ovl (make-overlay beg end (current-buffer))))
(overlay-put ovl ledger-occur-overlay-property-name t)
(overlay-put ovl 'face 'ledger-occur-xact-face)))
(defun ledger-occur-create-xact-overlays (ovl-bounds) (defun ledger-occur-make-invisible-overlay (beg end)
"Create the overlay for the visible transactions. (let ((ovl (make-overlay beg end (current-buffer))))
(overlay-put ovl ledger-occur-overlay-property-name t)
(overlay-put ovl 'invisible t)))
(defun ledger-occur-create-overlays (ovl-bounds)
"Create the overlays for the visible transactions.
Argument OVL-BOUNDS contains bounds for the transactions to be left visible." Argument OVL-BOUNDS contains bounds for the transactions to be left visible."
(let ((overlays (let* ((beg (caar ovl-bounds))
(mapcar (lambda (bnd) (end (cadar ovl-bounds)))
(make-overlay (car bnd) (ledger-occur-make-invisible-overlay (point-min) (1- beg))
(cadr bnd) (dolist (visible (cdr ovl-bounds))
(current-buffer) t nil)) (ledger-occur-make-visible-overlay beg end)
ovl-bounds))) (ledger-occur-make-invisible-overlay (1+ end) (1- (car visible)))
(mapcar (lambda (ovl) (setq beg (car visible))
(overlay-put ovl ledger-occur-overlay-property-name t) (setq end (cadr visible)))
(if ledger-occur-use-face-shown (ledger-occur-make-invisible-overlay (1+ end) (point-max))))
(overlay-put ovl 'face 'ledger-occur-xact-face )))
overlays)))
(defun ledger-occur-quit-buffer (buffer) (defun ledger-occur-quit-buffer (buffer)
"Quits hidings transaction in the given BUFFER. "Quits hidings transaction in the given BUFFER.
@ -164,45 +148,44 @@ Used for coordinating `ledger-occur' with other buffers, like reconcile."
"Remove the transaction hiding overlays." "Remove the transaction hiding overlays."
(interactive) (interactive)
(remove-overlays (point-min) (remove-overlays (point-min)
(point-max) ledger-occur-overlay-property-name t) (point-max) ledger-occur-overlay-property-name t)
(setq ledger-occur-overlay-list nil)) (setq ledger-occur-overlay-list nil))
(defun ledger-occur-create-xact-overlay-bounds (buffer-matches)
"Use BUFFER-MATCHES to produce the overlay for the visible transactions."
(let ((prev-end (point-min))
(overlays (list)))
(when buffer-matches
(mapc (lambda (line)
(push (list (car line) (cadr line)) overlays)
(setq prev-end (cadr line)))
buffer-matches)
(setq overlays (nreverse overlays)))))
(defun ledger-occur-find-matches (regex) (defun ledger-occur-find-matches (regex)
"Return a list of 2-number tuples describing the beginning and start of transactions meeting REGEX." "Return a list of 2-number tuples describing the beginning and end of transactions meeting REGEX."
(save-excursion (save-excursion
(goto-char (point-min)) (goto-char (point-min))
;; Set initial values for variables ;; Set initial values for variables
(let (curpoint (let (curpoint
endpoint endpoint
(lines (list))) (lines (list)))
;; Search loop ;; Search loop
(while (not (eobp)) (while (not (eobp))
(setq curpoint (point)) (setq curpoint (point))
;; if something found ;; if something found
(when (setq endpoint (re-search-forward regex nil 'end)) (when (setq endpoint (re-search-forward regex nil 'end))
(save-excursion (save-excursion
(let ((bounds (ledger-find-xact-extents (match-beginning 0)))) (let ((bounds (ledger-find-xact-extents (match-beginning 0))))
(push bounds lines) (push bounds lines)
(setq curpoint (cadr bounds)))) ;; move to the end of (setq curpoint (cadr bounds)))) ;; move to the end of
;; the xact, no need to ;; the xact, no need to
;; search inside it more ;; search inside it more
(goto-char curpoint)) (goto-char curpoint))
(forward-line 1)) (forward-line 1))
(setq lines (nreverse lines))))) (setq lines (nreverse lines)))))
(defun ledger-occur-compress-matches (buffer-matches)
"identify sequential xacts to reduce number of overlays required"
(let ((points (list))
(current-beginning (caar buffer-matches))
(current-end (cadar buffer-matches)))
(dolist (match (cdr buffer-matches))
(if (< (- (car match) current-end) 2)
(setq current-end (cadr match))
(push (list current-beginning current-end) points)
(setq current-beginning (car match))
(setq current-end (cadr match))))
(nreverse (push (list current-beginning current-end) points))))
(provide 'ldg-occur) (provide 'ldg-occur)

3
lisp/ldg-regex.el
View file

@ -70,6 +70,9 @@
(defconst ledger-account-any-status-regex (defconst ledger-account-any-status-regex
"^[ \t]+\\([*!]\\s-+\\)?\\([[(]?.+?\\)\\(\t\\|\n\\| [ \t]\\)") "^[ \t]+\\([*!]\\s-+\\)?\\([[(]?.+?\\)\\(\t\\|\n\\| [ \t]\\)")
(defun ledger-account-any-status-with-seed-regex (seed)
(concat "^[ \t]+\\([*!]\\s-+\\)?\\([[(]?" seed ".+?\\)\\(\t\\|\n\\| [ \t]\\)"))
(defconst ledger-account-pending-regex (defconst ledger-account-pending-regex
"\\(^[ \t]+\\)\\(!\\s-*.*?\\)\\( \\|\t\\|$\\)") "\\(^[ \t]+\\)\\(!\\s-*.*?\\)\\( \\|\t\\|$\\)")