diff --git a/org-ql-completing-read.el b/org-ql-completing-read.el new file mode 100644 index 0000000..81d8557 --- /dev/null +++ b/org-ql-completing-read.el @@ -0,0 +1,227 @@ +;;; org-ql-completing-read.el --- Completing read of Org entries using org-ql -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Adam Porter + +;; Author: Adam Porter + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This library provides completing-read of Org entries using `org-ql' +;; search. + +;;; Code: + +(require 'org-ql) + +;;;; Customization + +(defgroup org-ql-completing-read nil + "Completing-read of Org entries using `org-ql' search." + :group 'org-ql) + +(defcustom org-ql-completing-read-reverse-paths t + "Whether to reverse Org outline paths in `org-ql-completing-read' results." + :type 'boolean) + +(defcustom org-ql-completing-read-snippet-function #'org-ql-completing-read--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-completing-read'. +Function is called at entry beginning. (When set to +`org-ql-completing-read--snippet-regexp', it is called with a +regexp matching plain query tokens.)" + :type '(choice (function-item :tag "Show context around search terms" org-ql-completing-read--snippet-regexp) + (function-item :tag "Show first N characters" org-ql-completing-read--snippet-simple) + (function :tag "Custom function"))) + +(defcustom org-ql-completing-read-snippet-length 51 + "Size of snippets of entry content to include in completion annotations. +Only used when `org-ql-completing-read-snippet-function' is set +to `org-ql-completing-read--snippet-regexp'." + :type 'integer) + +(defcustom org-ql-completing-read-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-completing-read-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-completing-read-snippet '((t (:inherit font-lock-comment-face))) + "Snippets.") + +;;;; Functions + +;;;;; Completing read + +;;;###autoload +(cl-defun org-ql-completing-read (buffers-files &key query-prefix query-filter + (prompt "Find entry: ")) + "Return marker at Org entry in BUFFERS-FILES selected with `org-ql'. + +QUERY-PREFIX may be a string to prepend to the query entered by +the user (e.g. use \"heading:\" to only search headings, easily +creating a custom command that saves the user from having to type +it). + +QUERY-FILTER may be a function through which the query the user +types is filtered before execution (e.g. it could replace spaces +with commas to turn multiple tokens, which would normally be +treated as multiple predicates, into multiple arguments to a +single predicate)." + (declare (indent defun)) + ;; Emacs's completion API is not always easy to understand, + ;; especially when using "programmed completion." This code was + ;; made possible by the example Clemens Radermacher shared at + ;; . + (let ((table (make-hash-table :test #'equal)) + (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) + (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)) + (affix (completions) + (cl-loop for completion in completions + for marker = (gethash completion table) + for todo-state = (if-let (it (org-entry-get marker "TODO")) + (concat (propertize it + 'face (org-get-todo-face it)) + " ") + "") + for snippet = (if-let (it (snippet marker)) + (propertize (concat " " it) + 'face 'org-ql-completing-read-snippet) + "") + collect (list completion todo-state snippet))) + (annotate (candidate) + (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 + (or (funcall org-ql-completing-read-snippet-function snippet-regexp) + (org-ql-completing-read--snippet-simple)))) + (group (candidate transform) + (pcase transform + (`nil (buffer-name (marker-buffer (gethash candidate table)))) + (_ candidate))) + (try (string _table _pred point &optional _metadata) + (cons string point)) + (all (string table pred _point) + (all-completions string table pred)) + (collection (str _pred flag) + (when query-prefix + (setf str (concat query-prefix str))) + (pcase flag + ('metadata (list 'metadata + (cons 'group-function #'group) + (cons 'affixation-function #'affix) + (cons 'annotation-function #'annotate))) + (`t (unless (string-empty-p str) + (when query-filter + (setf str (funcall query-filter str))) + (pcase org-ql-completing-read-snippet-function + ('org-ql-completing-read--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-completing-read-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 str) + :action #'action)))))) + ;; 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 prepare + ;; an Org buffer when an Org file is loaded. This results in, + ;; e.g. the buffer being left in fundamental-mode, unprepared to + ;; be used as an Org buffer, which breaks many things and is + ;; very confusing for the user. Ideally, of course, we would + ;; solve this in `org-ql-select', and we already attempt to, but + ;; that function is called by the `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 `completing-read'. + (unless (listp buffers-files) + ;; Since we map across this argument, we ensure it's a list. + (setf buffers-files (list buffers-files))) + (mapc #'org-ql--ensure-buffer buffers-files) + (let* ((completion-styles '(org-ql-completing-read)) + (completion-styles-alist (list (list 'org-ql-completing-read #'try #'all "Org QL Find"))) + (selected (completing-read prompt #'collection nil))) + (gethash selected table))))) + +(defun org-ql-completing-read--snippet-simple (&optional _regexp) + "Return a snippet of the current entry. +Returns up to `org-ql-completing-read-snippet-length' characters." + (save-excursion + (org-end-of-meta-data t) + (unless (org-at-heading-p) + (let ((end (min (+ (point) org-ql-completing-read-snippet-length) + (org-entry-end-position)))) + (concat org-ql-completing-read-snippet-prefix + (truncate-string-to-width + (replace-regexp-in-string "\n" " " (buffer-substring (point) end) + t t) + 50 nil nil t)))))) + +(defun org-ql-completing-read--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 + (save-excursion + (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-completing-read-snippet-prefix + (replace-regexp-in-string (rx (1+ "\n")) " " snippets t t)))))))) + +;;;; Footer + +(provide 'org-ql-completing-read) + +;;; org-ql-completing-read.el ends here diff --git a/org-ql-find.el b/org-ql-find.el index 143a861..a85b937 100644 --- a/org-ql-find.el +++ b/org-ql-find.el @@ -31,6 +31,7 @@ (require 'org) (require 'org-ql) (require 'org-ql-search) +(require 'org-ql-completing-read) ;;;; Customization @@ -38,51 +39,10 @@ "Options for `org-ql-find'." :group 'org-ql) -(defcustom org-ql-find-reverse-paths t - "Whether to reverse Org outline paths in `org-ql-find' results." - :type 'boolean) - (defcustom org-ql-find-goto-hook '(org-show-entry) "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.") - ;;;; Functions ;;;###autoload @@ -106,116 +66,23 @@ single predicate)." (mapcar #'get-buffer (completing-read-multiple "Buffers: " - (mapcar #'buffer-name - (cl-remove-if-not (lambda (buffer) - (eq 'org-mode (buffer-local-value 'major-mode buffer))) - (buffer-list))) nil t)) + (cl-loop for buffer in (buffer-list) + when (eq 'org-mode (buffer-local-value 'major-mode buffer)) + collect (buffer-name buffer)) + nil t)) (progn (unless (eq major-mode 'org-mode) (user-error "This is not an Org buffer: %S" (current-buffer))) (current-buffer))))) - ;; Emacs's completion API is not always easy to understand, - ;; especially when using "programmed completion." This code was - ;; made possible by the example Clemens Radermacher shared at - ;; . - (let ((table (make-hash-table :test #'equal)) - (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) - (org-format-outline-path window-width nil "") - (org-split-string ""))) - (path (if org-ql-find-reverse-paths - (string-join (nreverse path) "\\") - (string-join path "/")))) - (puthash path (point-marker) table) - path)) - (affix (completions) - (cl-loop for completion in completions - for marker = (gethash completion table) - for todo-state = (if-let (it (org-entry-get marker "TODO")) - (concat (propertize it - 'face (org-get-todo-face it)) - " ") - "") - for snippet = (if-let (it (snippet marker)) - (propertize (concat " " it) - 'face 'org-ql-find-snippet) - "") - collect (list completion todo-state snippet))) - (annotate (candidate) - (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 - (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)))) - (_ candidate))) - (try (string _table _pred point &optional _metadata) - (cons string point)) - (all (string table pred _point) - (all-completions string table pred)) - (collection (str _pred flag) - (when query-prefix - (setf str (concat query-prefix str))) - (pcase flag - ('metadata (list 'metadata - (cons 'group-function #'group) - (cons 'affixation-function #'affix) - (cons 'annotation-function #'annotate))) - (`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 str) - :action #'action)))))) - ;; 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 prepare - ;; an Org buffer when an Org file is loaded. This results in, - ;; e.g. the buffer being left in fundamental-mode, unprepared to - ;; be used as an Org buffer, which breaks many things and is - ;; very confusing for the user. Ideally, of course, we would - ;; solve this in `org-ql-select', and we already attempt to, but - ;; that function is called by the `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 `completing-read'. - (unless (listp buffers-files) - ;; Since we map across this argument, we ensure it's a list. - (setf buffers-files (list buffers-files))) - (mapc #'org-ql--ensure-buffer buffers-files) - (let* ((completion-styles '(org-ql-find)) - (completion-styles-alist (list (list 'org-ql-find #'try #'all "Org QL Find"))) - (selected (completing-read prompt #'collection nil)) - (marker (gethash selected table))) - (with-current-buffer (marker-buffer marker) - (goto-char marker) - (display-buffer (current-buffer)) - (select-window (get-buffer-window (current-buffer))) - (run-hook-with-args 'org-ql-find-goto-hook)))))) + (let ((marker (org-ql-completing-read buffers-files + :query-prefix query-prefix + :query-filter query-filter + :prompt prompt))) + (with-current-buffer (marker-buffer marker) + (goto-char marker) + (display-buffer (current-buffer)) + (select-window (get-buffer-window (current-buffer))) + (run-hook-with-args 'org-ql-find-goto-hook)))) ;;;###autoload (defun org-ql-find-in-agenda () @@ -229,35 +96,6 @@ single predicate)." (interactive) (org-ql-find (org-ql-search-directories-files))) -(defun org-ql-find--snippet-simple (&optional _regexp) - "Return a snippet of the current entry. -Returns up to `org-ql-find-snippet-length' characters." - (save-excursion - (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 - (save-excursion - (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