Add/Change: org-ql-completing-read, etc.
This commit is contained in:
Adam Porter
parent
18869c47ff
commit
cfa3b307ec
2 changed files with 241 additions and 176 deletions
190
org-ql-find.el
190
org-ql-find.el
|
|
@ -31,6 +31,7 @@
|
|||
(require 'org)
|
||||
(require 'org-ql)
|
||||
(require 'org-ql-search)
|
||||
(require 'org-ql-completing-read)
|
||||
|
||||
;;;; Customization
|
||||
|
||||
|
|
@ -38,51 +39,10 @@
|
|||
"Options for `org-ql-find'."
|
||||
:group 'org-ql)
|
||||
|
||||
(defcustom org-ql-find-reverse-paths t
|
||||
"Whether to reverse Org outline paths in `org-ql-find' results."
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom org-ql-find-goto-hook '(org-show-entry)
|
||||
"Functions called when selecting an entry."
|
||||
:type 'hook)
|
||||
|
||||
(defcustom org-ql-find-snippet-function #'org-ql-find--snippet-simple
|
||||
;; TODO: I'd like to make the -regexp one the default, but with
|
||||
;; default Emacs completion affixation, it can sometimes be a bit
|
||||
;; slow, and I don't want that to be a user's first impression. It
|
||||
;; may be possible to further optimize the -regexp one so that it
|
||||
;; can be used by default. In the meantime, the -simple one seems
|
||||
;; fast enough for general use.
|
||||
"Function used to annotate results in `org-ql-find'.
|
||||
Function is called at entry beginning. (When set to
|
||||
`org-ql-find--snippet-regexp', it is called with a regexp
|
||||
matching plain query tokens.)"
|
||||
:type '(choice (function-item :tag "Show context around search terms" org-ql-find--snippet-regexp)
|
||||
(function-item :tag "Show first N characters" org-ql-find--snippet-simple)
|
||||
(function :tag "Custom function")))
|
||||
|
||||
(defcustom org-ql-find-snippet-length 51
|
||||
"Size of snippets of entry content to include in `org-ql-find' annotations.
|
||||
Only used when `org-ql-find-snippet-function' is set to
|
||||
`org-ql-find--snippet-regexp'."
|
||||
:type 'integer)
|
||||
|
||||
(defcustom org-ql-find-snippet-minimum-token-length 3
|
||||
"Query tokens shorter than this many characters are ignored.
|
||||
That is, they are not included when gathering entry snippets.
|
||||
This avoids too-small tokens causing performance problems."
|
||||
:type 'integer)
|
||||
|
||||
(defcustom org-ql-find-snippet-prefix nil
|
||||
"String prepended to snippets.
|
||||
For an experience like `org-rifle', use a newline."
|
||||
:type '(choice (const :tag "None (shown on same line)" nil)
|
||||
(const :tag "New line (shown under heading)" "\n")
|
||||
string))
|
||||
|
||||
(defface org-ql-find-snippet '((t (:inherit font-lock-comment-face)))
|
||||
"Snippets.")
|
||||
|
||||
;;;; Functions
|
||||
|
||||
;;;###autoload
|
||||
|
|
@ -106,116 +66,23 @@ single predicate)."
|
|||
(mapcar #'get-buffer
|
||||
(completing-read-multiple
|
||||
"Buffers: "
|
||||
(mapcar #'buffer-name
|
||||
(cl-remove-if-not (lambda (buffer)
|
||||
(eq 'org-mode (buffer-local-value 'major-mode buffer)))
|
||||
(buffer-list))) nil t))
|
||||
(cl-loop for buffer in (buffer-list)
|
||||
when (eq 'org-mode (buffer-local-value 'major-mode buffer))
|
||||
collect (buffer-name buffer))
|
||||
nil t))
|
||||
(progn
|
||||
(unless (eq major-mode 'org-mode)
|
||||
(user-error "This is not an Org buffer: %S" (current-buffer)))
|
||||
(current-buffer)))))
|
||||
;; Emacs's completion API is not always easy to understand,
|
||||
;; especially when using "programmed completion." This code was
|
||||
;; made possible by the example Clemens Radermacher shared at
|
||||
;; <https://github.com/radian-software/selectrum/issues/114#issuecomment-744041532>.
|
||||
(let ((table (make-hash-table :test #'equal))
|
||||
(window-width (window-width))
|
||||
query-tokens snippet-regexp)
|
||||
(cl-labels ((action
|
||||
() (font-lock-ensure (point-at-bol) (point-at-eol))
|
||||
(let* ((path (thread-first (org-get-outline-path t t)
|
||||
(org-format-outline-path window-width nil " ")
|
||||
(org-split-string " ")))
|
||||
(path (if org-ql-find-reverse-paths
|
||||
(string-join (nreverse path) "\\")
|
||||
(string-join path "/"))))
|
||||
(puthash path (point-marker) table)
|
||||
path))
|
||||
(affix (completions)
|
||||
(cl-loop for completion in completions
|
||||
for marker = (gethash completion table)
|
||||
for todo-state = (if-let (it (org-entry-get marker "TODO"))
|
||||
(concat (propertize it
|
||||
'face (org-get-todo-face it))
|
||||
" ")
|
||||
"")
|
||||
for snippet = (if-let (it (snippet marker))
|
||||
(propertize (concat " " it)
|
||||
'face 'org-ql-find-snippet)
|
||||
"")
|
||||
collect (list completion todo-state snippet)))
|
||||
(annotate (candidate)
|
||||
(while-no-input
|
||||
;; Using `while-no-input' here doesn't make it as
|
||||
;; responsive as, e.g. Helm while typing, but it seems to
|
||||
;; help a little when using the org-rifle-style snippets.
|
||||
(or (snippet (gethash candidate table)) "")))
|
||||
(snippet (marker)
|
||||
(org-with-point-at marker
|
||||
(or (funcall org-ql-find-snippet-function snippet-regexp)
|
||||
(org-ql-find--snippet-simple))))
|
||||
(group (candidate transform)
|
||||
(pcase transform
|
||||
(`nil (buffer-name (marker-buffer (gethash candidate table))))
|
||||
(_ candidate)))
|
||||
(try (string _table _pred point &optional _metadata)
|
||||
(cons string point))
|
||||
(all (string table pred _point)
|
||||
(all-completions string table pred))
|
||||
(collection (str _pred flag)
|
||||
(when query-prefix
|
||||
(setf str (concat query-prefix str)))
|
||||
(pcase flag
|
||||
('metadata (list 'metadata
|
||||
(cons 'group-function #'group)
|
||||
(cons 'affixation-function #'affix)
|
||||
(cons 'annotation-function #'annotate)))
|
||||
(`t (unless (string-empty-p str)
|
||||
(when query-filter
|
||||
(setf str (funcall query-filter str)))
|
||||
(pcase org-ql-find-snippet-function
|
||||
('org-ql-find--snippet-regexp
|
||||
(setf query-tokens
|
||||
;; Remove any tokens that specify predicates or are too short.
|
||||
(--select (not (or (string-match-p (rx bos (1+ (not (any ":"))) ":") it)
|
||||
(< (length it) org-ql-find-snippet-minimum-token-length)))
|
||||
(split-string str nil t (rx space)))
|
||||
snippet-regexp
|
||||
(when query-tokens
|
||||
;; Limiting each context word to 15 characters
|
||||
;; prevents excessively long, non-word strings
|
||||
;; from ending up in snippets, which can
|
||||
;; adversely affect performance.
|
||||
(rx-to-string `(seq (optional (repeat 1 3 (repeat 1 15 (not space)) (0+ space)))
|
||||
bow (or ,@query-tokens) (0+ (not space))
|
||||
(optional (repeat 1 3 (0+ space) (repeat 1 15 (not space))))))))))
|
||||
(org-ql-select buffers-files (org-ql--query-string-to-sexp str)
|
||||
:action #'action))))))
|
||||
;; NOTE: It seems that the `completing-read' machinery can call,
|
||||
;; abort, and re-call the collection function while the user is
|
||||
;; typing, which can interrupt the machinery Org uses to prepare
|
||||
;; an Org buffer when an Org file is loaded. This results in,
|
||||
;; e.g. the buffer being left in fundamental-mode, unprepared to
|
||||
;; be used as an Org buffer, which breaks many things and is
|
||||
;; very confusing for the user. Ideally, of course, we would
|
||||
;; solve this in `org-ql-select', and we already attempt to, but
|
||||
;; that function is called by the `completing-read' machinery,
|
||||
;; which interrupts it, so we must work around this problem by
|
||||
;; ensuring all of the BUFFERS-FILES are loaded and initialized
|
||||
;; before calling `completing-read'.
|
||||
(unless (listp buffers-files)
|
||||
;; Since we map across this argument, we ensure it's a list.
|
||||
(setf buffers-files (list buffers-files)))
|
||||
(mapc #'org-ql--ensure-buffer buffers-files)
|
||||
(let* ((completion-styles '(org-ql-find))
|
||||
(completion-styles-alist (list (list 'org-ql-find #'try #'all "Org QL Find")))
|
||||
(selected (completing-read prompt #'collection nil))
|
||||
(marker (gethash selected table)))
|
||||
(with-current-buffer (marker-buffer marker)
|
||||
(goto-char marker)
|
||||
(display-buffer (current-buffer))
|
||||
(select-window (get-buffer-window (current-buffer)))
|
||||
(run-hook-with-args 'org-ql-find-goto-hook))))))
|
||||
(let ((marker (org-ql-completing-read buffers-files
|
||||
:query-prefix query-prefix
|
||||
:query-filter query-filter
|
||||
:prompt prompt)))
|
||||
(with-current-buffer (marker-buffer marker)
|
||||
(goto-char marker)
|
||||
(display-buffer (current-buffer))
|
||||
(select-window (get-buffer-window (current-buffer)))
|
||||
(run-hook-with-args 'org-ql-find-goto-hook))))
|
||||
|
||||
;;;###autoload
|
||||
(defun org-ql-find-in-agenda ()
|
||||
|
|
@ -229,35 +96,6 @@ single predicate)."
|
|||
(interactive)
|
||||
(org-ql-find (org-ql-search-directories-files)))
|
||||
|
||||
(defun org-ql-find--snippet-simple (&optional _regexp)
|
||||
"Return a snippet of the current entry.
|
||||
Returns up to `org-ql-find-snippet-length' characters."
|
||||
(save-excursion
|
||||
(org-end-of-meta-data t)
|
||||
(unless (org-at-heading-p)
|
||||
(let ((end (min (+ (point) org-ql-find-snippet-length)
|
||||
(org-entry-end-position))))
|
||||
(concat org-ql-find-snippet-prefix
|
||||
(truncate-string-to-width
|
||||
(replace-regexp-in-string "\n" " " (buffer-substring (point) end)
|
||||
t t)
|
||||
50 nil nil t))))))
|
||||
|
||||
(defun org-ql-find--snippet-regexp (regexp)
|
||||
"Return a snippet of the current entry's matches for REGEXP."
|
||||
;; REGEXP may be nil if there are no qualifying tokens in the query.
|
||||
(when regexp
|
||||
(save-excursion
|
||||
(org-end-of-meta-data t)
|
||||
(unless (org-at-heading-p)
|
||||
(let* ((end (org-entry-end-position))
|
||||
(snippets (cl-loop while (re-search-forward regexp end t)
|
||||
concat (match-string 0) concat "…"
|
||||
do (goto-char (match-end 0)))))
|
||||
(unless (string-empty-p snippets)
|
||||
(concat org-ql-find-snippet-prefix
|
||||
(replace-regexp-in-string (rx (1+ "\n")) " " snippets t t))))))))
|
||||
|
||||
(provide 'org-ql-find)
|
||||
|
||||
;;; org-ql-find.el ends here
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue