jiri/org-ql
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

WIP: Many improvements

Browse source 
Now need to do some kind of sorting...
This commit is contained in:
Adam Porter 2023-03-16 07:11:11 -05:00
parent deada67e1d
commit 28f5aa3100
2 changed files with 74 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

64
org-ql-completing-read.el
View file

@ -73,40 +73,45 @@ For an experience like `org-rifle', use a newline."
(defface org-ql-completing-read-snippet '((t (:inherit font-lock-comment-face))) (defface org-ql-completing-read-snippet '((t (:inherit font-lock-comment-face)))
"Snippets.") "Snippets.")
(defvar org-ql-completing-read-input-regexp nil
"Current regexp for `org-ql-completing-read' input.
To be used in, e.g. annotation functions.")
;;;; Functions ;;;; Functions
(defun org-ql-completing-read-action (table) (defun org-ql-completing-read-action ()
"Default action for `org-ql-completing-read'." "Default action for `org-ql-completing-read'.
Returns (STRING . MARKER) cons."
(font-lock-ensure (point-at-bol) (point-at-eol)) (font-lock-ensure (point-at-bol) (point-at-eol))
(let* ((path (thread-first (org-get-outline-path t t) (cons (org-entry-get nil "ITEM") (point-marker)))
(org-format-outline-path window-width nil "")
(org-split-string "")))
(path (if org-ql-completing-read-reverse-paths
(string-join (nreverse path) "\\")
(string-join path "/"))))
(puthash path (point-marker) table)
path))
(defun org-ql-completing-read-annotate (candidate table) (defun org-ql-completing-read-snippet (marker)
"FIXME: Docstring."
(while-no-input (while-no-input
;; Using `while-no-input' here doesn't make it as ;; Using `while-no-input' here doesn't make it as
;; responsive as, e.g. Helm while typing, but it seems to ;; responsive as, e.g. Helm while typing, but it seems to
;; help a little when using the org-rifle-style snippets. ;; help a little when using the org-rifle-style snippets.
(or (org-ql-completing-read-snippet (gethash candidate table)) "")))
(defun org-ql-completing-read-snippet (marker)
(org-with-point-at marker (org-with-point-at marker
(or (funcall org-ql-completing-read-snippet-function snippet-regexp) (or (funcall org-ql-completing-read-snippet-function)
(org-ql-completing-read--snippet-simple)))) (org-ql-completing-read--snippet-simple)))))
;;;;; Completing read ;;;;; Completing read
;;;###autoload ;;;###autoload
(cl-defun org-ql-completing-read (buffers-files &key query-prefix query-filter (cl-defun org-ql-completing-read
(buffers-files &key query-prefix query-filter
(action #'org-ql-completing-read-action) (action #'org-ql-completing-read-action)
(annotate #'org-ql-completing-read-annotate) (annotate #'org-ql-completing-read-snippet)
(collection-filter #'identity) (snippet #'org-ql-completing-read-snippet)
(path (lambda (marker)
(org-with-point-at marker
(let* ((path (thread-first (org-get-outline-path nil t)
(org-format-outline-path (window-width) nil "")
(org-split-string "")))
(formatted-path (if org-ql-completing-read-reverse-paths
(concat "\\" (string-join (reverse path) "\\"))
(concat "/" (string-join path "/")))))
formatted-path))))
(action-filter #'list)
(prompt "Find entry: ")) (prompt "Find entry: "))
"Return marker at Org entry in BUFFERS-FILES selected with `org-ql'. "Return marker at Org entry in BUFFERS-FILES selected with `org-ql'.
PROMPT is shown to the user. PROMPT is shown to the user.
@ -135,7 +140,7 @@ single predicate)."
(let ((table (make-hash-table :test #'equal)) (let ((table (make-hash-table :test #'equal))
(disambiguations (make-hash-table :test #'equal)) (disambiguations (make-hash-table :test #'equal))
(window-width (window-width)) (window-width (window-width))
last-input org-outline-path-cache query-tokens snippet-regexp) last-input org-outline-path-cache query-tokens)
(cl-labels (;; (debug-message (cl-labels (;; (debug-message
;; (f &rest args) (apply #'message (concat "ORG-QL-COMPLETING-READ: " f) args)) ;; (f &rest args) (apply #'message (concat "ORG-QL-COMPLETING-READ: " f) args))
(action (action
@ -177,7 +182,7 @@ single predicate)."
(cl-loop for completion in completions (cl-loop for completion in completions
for marker = (get-text-property 0 'org-marker completion) for marker = (get-text-property 0 'org-marker completion)
for prefix = (todo marker) for prefix = (todo marker)
for suffix = (concat (path marker) " " (snippet marker)) for suffix = (concat (funcall path marker) " " (funcall snippet marker))
collect (list completion prefix suffix))) collect (list completion prefix suffix)))
(annotate (candidate) (annotate (candidate)
;; (debug-message "ANNOTATE:%S" candidate) ;; (debug-message "ANNOTATE:%S" candidate)
@ -268,23 +273,19 @@ single predicate)."
(clrhash disambiguations) (clrhash disambiguations)
(when query-filter (when query-filter
(setf input (funcall query-filter input))) (setf input (funcall query-filter input)))
(pcase org-ql-completing-read-snippet-function
('org-ql-completing-read--snippet-regexp
(setf query-tokens (setf query-tokens
;; Remove any tokens that specify predicates or are too short. ;; Remove any tokens that specify predicates or are too short.
(--select (not (or (string-match-p (rx bos (1+ (not (any ":"))) ":") it) (--select (not (or (string-match-p (rx bos (1+ (not (any ":"))) ":") it)
(< (length it) org-ql-completing-read-snippet-minimum-token-length))) (< (length it) org-ql-completing-read-snippet-minimum-token-length)))
(split-string input nil t (rx space))) (split-string input nil t (rx space)))
snippet-regexp org-ql-completing-read-input-regexp
(when query-tokens (when query-tokens
;; Limiting each context word to 15 characters prevents ;; Limiting each context word to 15 characters prevents
;; excessively long, non-word strings from ending up in ;; excessively long, non-word strings from ending up in
;; snippets, which can adversely affect performance. ;; snippets, which can adversely affect performance.
(rx-to-string `(seq (optional (repeat 1 3 (repeat 1 15 (not space)) (0+ space))) (rx-to-string `(seq (optional (repeat 1 3 (repeat 1 15 (not space)) (0+ space)))
bow (or ,@query-tokens) (0+ (not space)) bow (or ,@query-tokens) (0+ (not space))
(optional (repeat 1 3 (0+ space) (repeat 1 15 (not space)))))))))) (optional (repeat 1 3 (0+ space) (repeat 1 15 (not space))))))))
(org-ql-select buffers-files (org-ql--query-string-to-sexp input)
:action #'action))))
;; NOTE: It seems that the `completing-read' machinery can call, abort, and re-call the ;; 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 ;; 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 ;; prepare an Org buffer when an Org file is loaded. This results in, e.g. the buffer being
@ -294,9 +295,8 @@ single predicate)."
;; `completing-read' machinery, which interrupts it, so we must work around this problem by ;; `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 ;; ensuring all of the BUFFERS-FILES are loaded and initialized before calling
;; `completing-read'. ;; `completing-read'.
(funcall collection-filter (org-ql-select buffers-files (org-ql--query-string-to-sexp input)
(org-ql-select buffers-files (org-ql--query-string-to-sexp str) :action #'action))))
:action #'action)))))))
(unless (listp buffers-files) (unless (listp buffers-files)
;; Since we map across this argument, we ensure it's a list. ;; Since we map across this argument, we ensure it's a list.
(setf buffers-files (list buffers-files))) (setf buffers-files (list buffers-files)))
@ -318,7 +318,7 @@ single predicate)."
(car (hash-table-values table)) (car (hash-table-values table))
(user-error "No results for input")))))) (user-error "No results for input"))))))
(defun org-ql-completing-read--snippet-simple (&optional _regexp) (defun org-ql-completing-read--snippet-simple ()
"Return a snippet of the current entry. "Return a snippet of the current entry.
Returns up to `org-ql-completing-read-snippet-length' characters." Returns up to `org-ql-completing-read-snippet-length' characters."
(save-excursion (save-excursion

40
org-ql-find.el
View file

@ -159,31 +159,33 @@ which see (but only the files are used)."
(unless (eq major-mode 'org-mode) (unless (eq major-mode 'org-mode)
(user-error "This is not an Org buffer: %S" (current-buffer))) (user-error "This is not an Org buffer: %S" (current-buffer)))
(current-buffer))))) (current-buffer)))))
(let* ((org-ql-completing-read-snippet-function nil) (let* ((marker (org-ql-completing-read buffers-files
(marker (org-ql-completing-read buffers-files :query-prefix query-prefix
:query-prefix "rifle:" :query-filter query-filter
:query-filter (lambda (input)
(replace-regexp-in-string (rx (1+ space)) "," input t t))
:prompt prompt :prompt prompt
:collection-filter #'flatten-list :action-filter #'identity
:action (lambda (table) :action (lambda ()
(save-excursion (save-excursion
(cl-loop while (re-search-forward org-link-any-re (org-entry-end-position) t) (cl-loop with limit = (org-entry-end-position)
while (re-search-forward org-link-any-re limit t)
for link = (string-trim (match-string 0)) for link = (string-trim (match-string 0))
do (progn do (progn
(set-text-properties 0 (length link) '(face org-link) link) (set-text-properties 0 (length link) '(face org-link) link)
(setf link (org-link-display-format link)) (setf link (org-link-display-format link)))
(puthash link (copy-marker (match-beginning 0)) table)) collect (cons link (copy-marker (match-beginning 0))))))
collect link))) :snippet (lambda (&rest _)
:annotate (lambda (candidate table) "")
(org-with-point-at (gethash candidate table) :path (lambda (marker)
(concat " "
(org-format-outline-path (reverse (org-get-outline-path 'with-self))
nil nil "\\")
"::"
(abbreviate-file-name (buffer-file-name))))))))
(org-with-point-at marker (org-with-point-at marker
(org-open-at-point marker)))) (let* ((path (thread-first (org-get-outline-path t t)
(org-format-outline-path (window-width) nil "")
(org-split-string "")))
(formatted-path (if org-ql-completing-read-reverse-paths
(concat "\\" (string-join (reverse path) "\\"))
(concat "/" (string-join path "/")))))
formatted-path))))))
(org-with-point-at marker
(org-open-at-point))))
(provide 'org-ql-find) (provide 'org-ql-find)