Skip to content

Commit

Permalink
Add: (org-ql-find) Snippet functions
Browse files Browse the repository at this point in the history 
The default is even more like org-rifle now.
  • Loading branch information
@alphapapa
alphapapa committed Jun 11, 2022
1 parent ede1a6b commit 6e7371c
Showing 1 changed file with 85 additions and 10 deletions.
95 changes: 85 additions & 10 deletions org-ql-find.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.")

Expand Down Expand Up @@ -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)
Expand All @@ -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))))
Expand All @@ -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))
Expand Down Expand Up @@ -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

0 comments on commit 6e7371c

Please sign in to comment.