From 6e7371ce61198859b34e3b3468add59f284bf851 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sat, 11 Jun 2022 10:20:26 -0500 Subject: [PATCH] Add: (org-ql-find) Snippet functions The default is even more like org-rifle now. --- org-ql-find.el | 95 ++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 85 insertions(+), 10 deletions(-) diff --git a/org-ql-find.el b/org-ql-find.el index 20b6c572..69f0ad95 100644 --- a/org-ql-find.el +++ b/org-ql-find.el @@ -45,6 +45,40 @@ "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.") @@ -81,7 +115,8 @@ single predicate)." ;; made possible by the example Clemens Radermacher shared at ;; . (let ((table (make-hash-table :test #'equal)) - (window-width (window-width))) + (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) @@ -106,17 +141,15 @@ single predicate)." "") collect (list completion todo-state snippet))) (annotate (candidate) - (or (snippet (gethash candidate table)) "")) + (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 - (org-end-of-meta-data t) - (unless (org-at-heading-p) - (let ((end (min (+ (point) 51) - (org-entry-end-position)))) - (truncate-string-to-width - (replace-regexp-in-string "\n" " " (buffer-substring (point) end) - t t) - 50 nil nil t))))) + (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)))) @@ -134,6 +167,21 @@ single predicate)." (`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 (concat query-prefix str)) :action #'action)))))) (let* ((completion-styles '(org-ql-find)) @@ -181,6 +229,33 @@ multiple buffers to search with completion." (current-buffer)))) (org-ql-find buffers-files :prompt "Find outline path: " :query-prefix "outline-path:")) +(defun org-ql-find--snippet-simple (&optional _regexp) + "Return a snippet of the current entry. +Returns up to `org-ql-find-snippet-length' characters." + (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 + (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