Add: (org-ql-find) Snippet functions

The default is even more like org-rifle now.

Author: alphapapa

org-ql-find.el

@@ -45,6 +45,28 @@
   "Functions called when selecting an entry."
   :type 'hook)
 
+(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-function #'org-ql-find--snippet-regexp
+  "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-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 +103,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 +129,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 +155,15 @@ 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.
+                                             (--select (not (string-match-p (rx bos (1+ (not (any ":"))) ":") it))
+                                                       (split-string str nil t (rx space)))
+                                             snippet-regexp (rx-to-string `(seq (optional (repeat 1 3 (1+ (not space)) (0+ space)))
+                                                                                bow (or ,@query-tokens) (0+ (not space))
+                                                                                (optional (repeat 1 3 (0+ space) (1+ (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 +211,31 @@ 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."
+  (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