Add: (org-ql-find) Snippet functions

The default is even more like org-rifle now.

Author: alphapapa

Diff for: 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
   ;; <https://github.com/radian-software/selectrum/issues/114#issuecomment-744041532>.
   (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