mirror of
https://github.com/doomemacs/doomemacs
synced 2025-08-01 12:17:25 -05:00
5026de65bb
Auto-generates price files are a common feature among beancount users;
scanning them is a lot of unnecessary work when just reading commodity
directives (and operating_currency options) should be more than enough.
Amend: 5df769e994
280 lines
13 KiB
EmacsLisp
280 lines
13 KiB
EmacsLisp
;;; lang/beancount/autoload/advice.el -*- lexical-binding: t; -*-
|
|
|
|
(defun +beancount--included-files (&optional recursive? context)
|
|
"Return a list of included files in the current beancount buffer.
|
|
|
|
If RECURSIVE? is non-nil, included files will be read for each found include (as
|
|
will theirs, recursively)."
|
|
(let ((nested? (eq recursive? 'nested))
|
|
files)
|
|
(save-excursion
|
|
(save-restriction
|
|
(widen)
|
|
(goto-char (point-min))
|
|
(while (re-search-forward
|
|
(concat "^" (unless nested? "\\(?:;;;# \\)?")
|
|
(rx "include" (+ " ") "\"" (group (+ (not "\"")))))
|
|
nil t)
|
|
(when-let* ((path (match-string-no-properties 1)))
|
|
(setq path (expand-file-name path))
|
|
(dolist (file (if (string-match "[[*?]" path)
|
|
(doom-glob path)
|
|
(when (file-readable-p path)
|
|
(list path))))
|
|
(unless (and context
|
|
(let ((skip (doom-file-cookie file "skip")))
|
|
(or (eq skip t)
|
|
(memq context (ensure-list skip)))))
|
|
(cl-callf nconc files (list file))
|
|
(when recursive?
|
|
(with-temp-buffer
|
|
(insert-file-contents file)
|
|
(let ((default-directory
|
|
(directory-file-name
|
|
(file-name-directory file))))
|
|
(cl-callf nconc files (+beancount--included-files 'nested context)))))))))
|
|
(if nested?
|
|
files
|
|
(delete-dups files))))))
|
|
|
|
;;;###autoload
|
|
(defun +beancount--collect-unique-recursive (regexp n &optional context)
|
|
(let ((results (make-hash-table :test 'equal)))
|
|
(dolist (file (cons (buffer-file-name (buffer-base-buffer))
|
|
(if (eq +beancount-files 'auto)
|
|
(+beancount--included-files t context)
|
|
+beancount-files)))
|
|
(with-temp-buffer
|
|
(insert-file-contents file)
|
|
(dolist (x (beancount-collect-pos-alist regexp n))
|
|
(puthash (car x) `(:file ,file :point ,(cdr x))
|
|
results))))
|
|
results))
|
|
|
|
(defvar +beancount--completion-cache nil)
|
|
;;;###autoload
|
|
(defun +beancount-completion-table (regexp n context &optional sort-fn)
|
|
(lambda (string pred action)
|
|
(if (eq action 'metadata)
|
|
`(metadata
|
|
(category . ,(intern (format "beancount-%s" context)))
|
|
(display-sort-function . identity))
|
|
(make-local-variable '+beancount--completion-cache)
|
|
(with-current-buffer (let ((win (minibuffer-selected-window)))
|
|
(if (window-live-p win) (window-buffer win)
|
|
(current-buffer)))
|
|
(unless (assq context +beancount--completion-cache)
|
|
(with-memoization (alist-get context +beancount--completion-cache)
|
|
(+beancount--collect-unique-recursive regexp n context)))
|
|
(complete-with-action
|
|
action (sort (hash-table-keys
|
|
(alist-get context +beancount--completion-cache))
|
|
(or sort-fn #'string<))
|
|
string pred)))))
|
|
|
|
(defun +beancount-account-completion-table (&optional sort-fn)
|
|
(cl-callf2 assq-delete-all 'accounts +beancount--completion-cache)
|
|
(+beancount-completion-table
|
|
(concat "^" beancount-date-regexp " +open +\\(" beancount-account-regexp "\\)")
|
|
1 'accounts sort-fn))
|
|
|
|
;;;###autoload
|
|
(defun +beancount-completion-at-point-a ()
|
|
"Return the completion data relevant for the text at point."
|
|
(save-excursion
|
|
(save-match-data
|
|
(let ((pos (point)))
|
|
(beginning-of-line)
|
|
(cond
|
|
;; non timestamped directive
|
|
((beancount-looking-at "[a-z]*" 0 pos)
|
|
(list (match-beginning 0) (match-end 0)
|
|
(mapcar (lambda (s) (concat s " ")) beancount-directive-names)))
|
|
|
|
;; poptag
|
|
((beancount-looking-at
|
|
(concat "poptag\\s-+\\(\\(?:#[" beancount-tag-chars "]*\\)\\)") 1 pos)
|
|
(list (match-beginning 1) (match-end 1)
|
|
(beancount-collect-pushed-tags (point-min) (point))))
|
|
|
|
;; option
|
|
((beancount-looking-at
|
|
(concat "^option\\s-+\\(\"[a-z_]*\\)") 1 pos)
|
|
(list (match-beginning 1) (match-end 1)
|
|
(mapcar (lambda (s) (concat "\"" s "\" ")) beancount-option-names)))
|
|
|
|
;; NEW: event values (scoped by name)
|
|
;; REVIEW: PR this upstream
|
|
((beancount-looking-at
|
|
(concat beancount-date-regexp "\\s-+event\\s-+\"\\([^\"\n]+\\)\"\\s-+\"\\([^\"\n]*\\)")
|
|
2 pos)
|
|
(list (match-beginning 2) (match-end 2)
|
|
(+beancount-completion-table
|
|
(concat "^" beancount-date-regexp
|
|
"\\s-+event"
|
|
"\\s-+\"" (regexp-quote (match-string-no-properties 1)) "\""
|
|
"\\s-+\"\\([^\"\n]+\\)\"")
|
|
1 'event-values)))
|
|
|
|
;; NEW: event names
|
|
;; REVIEW: PR this upstream
|
|
((beancount-looking-at
|
|
(concat beancount-date-regexp "\\s-+event\\s-+\"\\([^\"\n]*\\)") 1 pos)
|
|
(list (match-beginning 1) (match-end 1)
|
|
(+beancount-completion-table
|
|
(concat "^" beancount-date-regexp
|
|
"\\s-+event"
|
|
"\\s-+\"\\([^\"\n]+\\)\"")
|
|
1 'events)))
|
|
|
|
;; NEW: transaction payees
|
|
;; REVIEW: PR this upstream (?)
|
|
((beancount-looking-at
|
|
(concat beancount-date-regexp "\\s-+" beancount-flag-regexp "\\s-+\"\\([^\"\n]*\\)")
|
|
1 pos)
|
|
(list (match-beginning 1) (match-end 1)
|
|
(+beancount-completion-table
|
|
(concat "^" beancount-date-regexp
|
|
"\\s-+" beancount-flag-regexp
|
|
"\\s-+\"\\([a-zA-Z0-9][^\"\n]+\\)\"")
|
|
1 'payees)))
|
|
|
|
;; timestamped directive
|
|
((beancount-looking-at
|
|
(concat beancount-date-regexp "\\s-+\\([[:alpha:]]*\\)") 1 pos)
|
|
(list (match-beginning 1) (match-end 1)
|
|
(mapcar (lambda (s) (concat s " ")) beancount-timestamped-directive-names)))
|
|
|
|
;; timestamped directives followed by account
|
|
((beancount-looking-at
|
|
(concat "^" beancount-date-regexp
|
|
"\\s-+" (regexp-opt beancount-account-directive-names)
|
|
"\\s-+\\([" beancount-account-chars "]*\\)") 1 pos)
|
|
(list (match-beginning 1) (match-end 1) (+beancount-account-completion-table)))
|
|
|
|
;; pad directive followed by two accounts
|
|
((beancount-looking-at
|
|
(concat "^" beancount-date-regexp
|
|
"\\s-+" (regexp-opt '("pad"))
|
|
"\\s-+\\([" beancount-account-chars "]*\\)"
|
|
"\\s-+\\([" beancount-account-chars "]*\\)") 2 pos)
|
|
(list (match-beginning 2) (match-end 2) (+beancount-account-completion-table)))
|
|
|
|
;; posting
|
|
((and (beancount-looking-at
|
|
(concat "[ \t]+\\([" beancount-account-chars "]*\\)") 1 pos)
|
|
;; Do not force the account name to start with a
|
|
;; capital, so that it is possible to use substring
|
|
;; completion and we can rely on completion to fix
|
|
;; capitalization thanks to completion-ignore-case.
|
|
(beancount-inside-transaction-p))
|
|
(list (match-beginning 1) (match-end 1) (+beancount-account-completion-table)))
|
|
|
|
;; tags & links
|
|
;; REVIEW: The upstream implementation only completes tags/links at
|
|
;; indentation and not at the end of transaction heading, where
|
|
;; they're typically used. This fixes that.
|
|
((progn
|
|
(goto-char pos)
|
|
(and (re-search-backward "[ \t]" (pos-bol) t)
|
|
(looking-at (concat "[ \t]+\\(\\([#^]\\)[" beancount-tag-chars "]*\\)"))
|
|
(>= pos (match-beginning 1))
|
|
(<= pos (match-end 1))))
|
|
(list (match-beginning 1) (match-end 1)
|
|
(+beancount-completion-table
|
|
(concat " \\(" (match-string-no-properties 2) "[" beancount-tag-chars "]+\\)")
|
|
1 (if (equal (match-string-no-properties 2) "#") 'tags 'links))))
|
|
|
|
((progn
|
|
(goto-char pos)
|
|
(and (looking-back (concat "\\s-" beancount-number-regexp
|
|
"\\s-+\\(\\(?:" beancount-currency-regexp
|
|
"\\)?\\)")
|
|
(pos-bol))
|
|
(>= pos (match-beginning 1))
|
|
(<= pos (match-end 1))))
|
|
(list (match-beginning 1) (match-end 1)
|
|
(+beancount-completion-table
|
|
(concat "^\\(?:" beancount-date-regexp
|
|
"\\s-+commodity\\s-+\\|"
|
|
"option\\s-+\"operating_currency\"\\s-+\""
|
|
"\\)\\(" beancount-currency-regexp "\\)")
|
|
1 'commodities))))))))
|
|
|
|
;;;###autoload
|
|
(defun +beancount-get-account-names-a (&rest _)
|
|
"Crawl `+beancount-files' for account names."
|
|
(unless beancount-accounts
|
|
(setq beancount-accounts
|
|
(hash-table-keys
|
|
(+beancount--collect-unique-recursive
|
|
(concat "^" beancount-date-regexp " +open +\\(" beancount-account-regexp "\\)")
|
|
1 'accounts))))
|
|
beancount-accounts)
|
|
|
|
;;;###autoload
|
|
(defun +beancount--flymake-bean-check--run-a (report-fn &rest _ignored)
|
|
(unless (executable-find flymake-bean-check-executable)
|
|
(error "The executable %s doesn't exist. See `flymake-bean-check-executable'"
|
|
flymake-bean-check-executable))
|
|
(when (and flymake-bean-check-process
|
|
(process-live-p flymake-bean-check-process))
|
|
(kill-process flymake-bean-check-process))
|
|
(let* ((source (current-buffer))
|
|
(buffer (generate-new-buffer "*flymake-bean-check*"))
|
|
(cache-file (flymake-bean-check-cache-filename (buffer-file-name))))
|
|
(setq flymake-bean-check-process
|
|
(make-process :buffer buffer
|
|
:name "flymake-bean-check"
|
|
:noquery t
|
|
:connection-type 'pipe
|
|
:command (list flymake-bean-check-executable
|
|
"/dev/stdin"
|
|
"--cache-filename" cache-file)
|
|
:sentinel
|
|
(lambda (proc _event)
|
|
(when (memq (process-status proc) '(exit signal))
|
|
(unwind-protect
|
|
(with-current-buffer buffer
|
|
(goto-char (point-min))
|
|
(let (result)
|
|
(while (re-search-forward flymake-bean-check-location-regexp
|
|
nil t)
|
|
(pcase-let*
|
|
((message (match-string 2))
|
|
(`(,begin . ,end) (flymake-diag-region
|
|
source
|
|
(string-to-number (match-string 1)))))
|
|
(push (flymake-make-diagnostic source begin end
|
|
:error message)
|
|
result)))
|
|
(funcall report-fn (nreverse result))))
|
|
(kill-buffer buffer))))))
|
|
(process-send-string
|
|
flymake-bean-check-process
|
|
(save-restriction
|
|
(widen)
|
|
(with-temp-buffer
|
|
(save-excursion (insert-buffer-substring source))
|
|
(save-excursion
|
|
(while (re-search-forward "^;+# " nil t)
|
|
(replace-match "" t t)))
|
|
(while (re-search-forward
|
|
(rx bol
|
|
(or (seq (= 4 num) "-" (= 2 num) "-" (= 2 num) (+ " ")
|
|
"document" (+ " ")
|
|
(+ (or alnum ":" "_" "-")))
|
|
"include"
|
|
(seq "option" (+ " ") "\"documents\""))
|
|
(+ " ") "\""
|
|
(group (+ (not "\""))))
|
|
nil t)
|
|
(unless (file-name-absolute-p (match-string-no-properties 1))
|
|
(replace-match (expand-file-name
|
|
(match-string-no-properties 1))
|
|
t t nil 1)))
|
|
(buffer-substring-no-properties (point-min) (point-max)))))
|
|
(process-send-eof flymake-bean-check-process)))
|
|
|
|
;;; advice.el ends here
|