Skip to content

Commit

Permalink
Add: (org-ql-find)
Browse files Browse the repository at this point in the history
  • Loading branch information
@alphapapa
alphapapa committed May 30, 2022
1 parent 8933f88 commit d0acc8c
Show file tree
Hide file tree
Showing 4 changed files with 496 additions and 265 deletions.
20 changes: 17 additions & 3 deletions README.org
View file
Original file line number Diff line number Diff line change
Expand Up @@ -94,15 +94,28 @@ Lisp code examples are in [[examples.org]].
:TOC: ignore-children
:END:

+ *Jumping to an entry:*
- [[#org-ql-find][org-ql-find]] (command)
- [[#helm-org-ql][helm-org-ql]] (command)
+ *Showing an agenda-like view:*
- [[#org-ql-search][org-ql-search]] (command)
- [[#org-ql-view][org-ql-view]] (command)
- [[#org-ql-view-sidebar][org-ql-view-sidebar]] (command)
- [[#org-ql-view-recent-items][org-ql-view-recent-items]] (command)
+ *Showing a tree in a buffer:*
- [[#org-ql-sparse-tree][org-ql-sparse-tree]] (command)
+ *Showing results with Helm*:
- [[#helm-org-ql][helm-org-ql]] (command)

*** org-ql-find

/Note: These commands use [[#non-sexp-query-syntax][non-sexp queries]]./

These commands jump to a heading selected using Emacs's built-in completion facilities with an Org QL query:

- ~org-ql-find~ searches all entry content.
- ~org-ql-find-path~ searches only headings (using the ~outline-path:~ predicate).
- ~org-ql-find-heading~ searches only headings (using the ~heading:~ predicate).

[[images/org-ql-find.png]]

*** org-ql-search

Expand Down Expand Up @@ -524,7 +537,8 @@ Simple links may also be written manually in either sexp or non-sexp form, like:

** 0.7-pre

Nothing new yet.
*Added*
+ Commands ~org-ql-find~, ~org-ql-find-heading~, and ~org-ql-find-path~, which jump to entries selected using Emacs's built-in completion facilities and Org QL queries (like ~helm-org-ql~, but doesn't require Helm.).

** 0.6.2

Expand Down
Binary file added images/org-ql-find.png
View file
Loading
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
178 changes: 178 additions & 0 deletions org-ql-find.el
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,178 @@
;;; org-ql-find.el --- Find headings with completion using org-ql -*- lexical-binding: t; -*-

;; Copyright (C) 2022 Adam Porter

;; Author: Adam Porter <[email protected]>

;; 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 <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This library provides a way to quickly find and go to Org entries
;; selected with Emacs's built-in completions API (so it works with
;; packages that extend it, like Vertico, Marginalia, etc). It works
;; like `helm-org-ql' but does not require Helm.

;;; Code:

(require 'cl-lib)

(require 'org)
(require 'org-ql)

;;;; Customization

(defgroup org-ql-find nil
"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)

(defface org-ql-find-snippet '((t (:inherit font-lock-comment-face)))
"Snippets.")

;;;; Functions

;;;###autoload
(cl-defun org-ql-find (buffers-files &key query-prefix
(prompt "Find entry: "))
"Go to an Org entry in BUFFERS-FILES selected by searching entries with `org-ql'.
Interactively, with universal prefix, select multiple buffers to
search with completion.
If QUERY-PREFIX, prepend it to the query (e.g. use \"heading:\"
to only search headings, easily creating a custom command that
saves the user from having to type it)."
(interactive
(list (if current-prefix-arg
(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))
(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
;; <https://github.com/radian-software/selectrum/issues/114#issuecomment-744041532>.
(let ((table (make-hash-table :test #'equal))
(window-width (window-width)))
(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)
(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)))))
(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)
(pcase flag
('metadata (list 'metadata
(cons 'group-function #'group)
(cons 'affixation-function #'affix)
(cons 'annotation-function #'annotate)))
(`t (unless (string-empty-p str)
(org-ql-select buffers-files (org-ql--query-string-to-sexp (concat query-prefix str))
:action #'action))))))
(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))
(run-hook-with-args 'org-ql-find-goto-hook))))))

;;;###autoload
(defun org-ql-find-heading (buffers-files)
"Go to an Org entry in BUFFERS-FILES selected by searching with `org-ql'.
Only headings are searched (using the \"heading:\" predicate).
Interactively, with universal prefix, select multiple buffers to
search with completion."
(interactive
(list (if current-prefix-arg
(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))
(current-buffer))))
(org-ql-find buffers-files :prompt "Find heading: " :query-prefix "heading:"))

;;;###autoload
(defun org-ql-find-path (buffers-files)
"Go to an Org entry in BUFFERS-FILES selected by searching with `org-ql'.
Only outline paths are searched (using the \"outline-path:\"
predicate). Interactively, with universal prefix, select
multiple buffers to search with completion."
(interactive
(list (if current-prefix-arg
(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))
(current-buffer))))
(org-ql-find buffers-files :prompt "Find outline path: " :query-prefix "outline-path:"))

(provide 'org-ql-find)

;;; org-ql-find.el ends here
Loading

4 comments on commit d0acc8c

@minad
Copy link

@minad minad commented on d0acc8c May 30, 2022

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Hey @alphapapa,

great that we have general completing-read support in org-ql now! But your solution looks a bit too complicated. See the follow example from https://github.com/minad/vertico#completion-table-dynamic.

(let ((completion-styles '(basic)))
  (completing-read "Dynamic: "
                   (completion-table-dynamic
                    (lambda (str)
                      (list (concat str "1")
                            (concat str "2")
                            (concat str "3"))))))

@minad
Copy link

@minad minad commented on d0acc8c May 30, 2022

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Or is the issue that you don't want the basic highlighting?

(defun completion-basic-no-hl-all-completions (string table pred _point)
  (all-completions string table pred))

(add-to-list 'completion-styles-alist
             '(basic-no-hl
               completion-basic-try-completion
               completion-basic-no-hl-all-completions
               ""))

(let ((completion-styles '(basic-no-hl)))
  (completing-read "Dynamic: "
                   (completion-table-dynamic
                    (lambda (str)
                      (list (concat str "1")
                            (concat str "2")
                            (concat str "3"))))))

@alphapapa
Copy link
Owner Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Hi Daniel,

Thanks for taking a look at the code. I was stymied by the completions API's support for "programmable completions" until I found that example Clemens posted.

I'm not surprised if the code I merged isn't ideal, and I have no objection to highlighting. I just took his example and ran with it, since it seems to work. If it can be simplified and still work as well, that would be great. I'll note this feedback in an issue and take a look at it in the future. :) Please feel free to let me know if you have more feedback.

@minad
Copy link

@minad minad commented on d0acc8c Jun 1, 2022 via email

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Please sign in to comment.