|
| 1 | +;;; helm-org-ql.el --- Helm commands for org-ql -*- lexical-binding: t; -*- |
| 2 | + |
| 3 | +;; Author: Adam Porter <[email protected]> |
| 4 | +;; URL: https://github.com/alphapapa/org-ql |
| 5 | + |
| 6 | +;;; Commentary: |
| 7 | + |
| 8 | +;; This library includes Helm commands for `org-ql'. Note that Helm |
| 9 | +;; is not declared as a package dependency, so this does not cause |
| 10 | +;; Helm to be installed. In the future, this file may have its own |
| 11 | +;; package recipe, which would allow it to be installed separately and |
| 12 | +;; declare a dependency on Helm. |
| 13 | + |
| 14 | +;;; License: |
| 15 | + |
| 16 | +;; This program is free software; you can redistribute it and/or modify |
| 17 | +;; it under the terms of the GNU General Public License as published by |
| 18 | +;; the Free Software Foundation, either version 3 of the License, or |
| 19 | +;; (at your option) any later version. |
| 20 | + |
| 21 | +;; This program is distributed in the hope that it will be useful, |
| 22 | +;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 23 | +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 24 | +;; GNU General Public License for more details. |
| 25 | + |
| 26 | +;; You should have received a copy of the GNU General Public License |
| 27 | +;; along with this program. If not, see <https://www.gnu.org/licenses/>. |
| 28 | + |
| 29 | +;;; Code: |
| 30 | + |
| 31 | +;;;; Requirements |
| 32 | + |
| 33 | +(require 'org) |
| 34 | + |
| 35 | +(require 'org-ql) |
| 36 | + |
| 37 | +;; (require 'helm) |
| 38 | +;; (require 'helm-org) |
| 39 | + |
| 40 | +;;;; Compatibility |
| 41 | + |
| 42 | +;; Declare Helm functions since Helm may not be installed. |
| 43 | +(declare-function helm "ext:helm") |
| 44 | +(declare-function helm-run-after-exit "ext:helm") |
| 45 | +(declare-function helm-buffer-get "ext:helm-lib") |
| 46 | +(declare-function helm-make-source "ext:helm-source") |
| 47 | +(declare-function helm-org-goto-marker "ext:helm-org") |
| 48 | + |
| 49 | +;; Silence byte-compiler about variables. |
| 50 | +(defvar helm-map) |
| 51 | +(defvar helm-pattern) |
| 52 | +(defvar helm-input-idle-delay) |
| 53 | + |
| 54 | +;;;; Variables |
| 55 | + |
| 56 | +(defvar helm-org-ql-map |
| 57 | + (let ((map (copy-keymap helm-map)) |
| 58 | + (mappings '( |
| 59 | + "C-x C-s" helm-org-ql-save |
| 60 | + ))) |
| 61 | + (cl-loop for (key fn) on mappings by #'cddr |
| 62 | + do (define-key map (kbd key) fn)) |
| 63 | + map) |
| 64 | + "Keymap for `helm-org-ql' sessions. |
| 65 | +Based on `helm-map'.") |
| 66 | + |
| 67 | +(defvar-local helm-org-ql-buffers-files nil |
| 68 | + "Used for `helm-org-ql-save'.") |
| 69 | + |
| 70 | +;;;; Customization |
| 71 | + |
| 72 | +(defgroup helm-org-ql nil |
| 73 | + "Options for `helm-org-ql'." |
| 74 | + :group 'org-ql) |
| 75 | + |
| 76 | +(defcustom helm-org-ql-reverse-paths t |
| 77 | + "Whether to reverse Org outline paths in `helm-org-ql' results." |
| 78 | + :type 'boolean) |
| 79 | + |
| 80 | +(defcustom helm-org-ql-input-idle-delay 0.25 |
| 81 | + "Seconds to wait after typing stops before running query." |
| 82 | + :type 'number) |
| 83 | + |
| 84 | +(defcustom helm-org-ql-actions |
| 85 | + (list (cons "Show heading in source buffer" 'helm-org-ql-show-marker) |
| 86 | + (cons "Show heading in indirect buffer" 'helm-org-ql-show-marker-indirect)) |
| 87 | + "Alist of actions for `helm-org-ql' commands." |
| 88 | + :type '(alist :key-type (string :tag "Description") |
| 89 | + :value-type (function :tag "Command"))) |
| 90 | + |
| 91 | +;;;; Commands |
| 92 | + |
| 93 | +;;;###autoload |
| 94 | +(cl-defun helm-org-ql (buffers-files &optional (no-and current-prefix-arg)) |
| 95 | + "Display results in BUFFERS-FILES for an `org-ql' query using Helm. |
| 96 | +Interactively, search the current buffer. |
| 97 | +
|
| 98 | +NOTE: Atoms in the query are turned into strings where |
| 99 | +appropriate, which makes it unnecessary to type quotation marks |
| 100 | +around words that are intended to be searched for as indepenent |
| 101 | +strings. |
| 102 | +
|
| 103 | +Also, unless NO-AND is non-nil (interactively, with prefix), all |
| 104 | +query tokens are wrapped in an implied (and) form. This is |
| 105 | +because a query must be a sexp, so when typing multiple clauses, |
| 106 | +either (and) or (or) would be required around them, and (and) is |
| 107 | +typically more useful, because it narrows down results. |
| 108 | +
|
| 109 | +For example, this raw input: |
| 110 | +
|
| 111 | + Emacs git |
| 112 | +
|
| 113 | +Is transformed into this query: |
| 114 | +
|
| 115 | + (and \"Emacs\" \"git\") |
| 116 | +
|
| 117 | +However, quoted strings remain quoted, so this input: |
| 118 | +
|
| 119 | + \"something else\" (tags \"funny\") |
| 120 | +
|
| 121 | +Is transformed into this query: |
| 122 | +
|
| 123 | + (and \"something else\" (tags \"funny\"))" |
| 124 | + (interactive (list (current-buffer))) |
| 125 | + (let ((helm-input-idle-delay helm-org-ql-input-idle-delay)) |
| 126 | + (helm :prompt (format "Query (boolean %s): " (if no-and |
| 127 | + "OR" |
| 128 | + "AND")) |
| 129 | + :sources |
| 130 | + ;; Expansion of `helm-build-sync-source' macro. |
| 131 | + (helm-make-source "helm-org-ql-agenda-files" 'helm-source-sync |
| 132 | + :candidates #'(lambda nil |
| 133 | + (let* ((query (helm-org-ql--input-to-query helm-pattern no-and)) |
| 134 | + (window-width (window-width (helm-window)))) |
| 135 | + (when query |
| 136 | + (with-current-buffer (helm-buffer-get) |
| 137 | + (setq helm-org-ql-buffers-files buffers-files)) |
| 138 | + (ignore-errors |
| 139 | + ;; Ignore errors that might be caused by partially typed queries. |
| 140 | + (org-ql-select buffers-files query |
| 141 | + :action (list 'helm-org-ql--heading window-width)))))) |
| 142 | + :match #'identity |
| 143 | + :fuzzy-match nil |
| 144 | + :multimatch nil |
| 145 | + :volatile t |
| 146 | + :keymap helm-org-ql-map |
| 147 | + :action helm-org-ql-actions)))) |
| 148 | + |
| 149 | +;;;###autoload |
| 150 | +(defun helm-org-ql-agenda-files () |
| 151 | + "Search agenda files with `helm-org-ql', which see." |
| 152 | + (interactive) |
| 153 | + (helm-org-ql (org-agenda-files))) |
| 154 | + |
| 155 | +;;;###autoload |
| 156 | +(defun helm-org-ql-org-directory () |
| 157 | + "Search Org files in `org-directory' with `helm-org-ql'." |
| 158 | + (interactive) |
| 159 | + (helm-org-ql (directory-files org-directory 'full |
| 160 | + (rx ".org" eos)))) |
| 161 | + |
| 162 | +(defun helm-org-ql-show-marker (marker) |
| 163 | + "Show heading at MARKER." |
| 164 | + (interactive) |
| 165 | + ;; This function is necessary because `helm-org-goto-marker' calls |
| 166 | + ;; `re-search-backward' to go backward to the start of a heading, |
| 167 | + ;; which, when the marker is already at the desired heading, causes |
| 168 | + ;; it to go to the previous heading. I don't know why it does that. |
| 169 | + (switch-to-buffer (marker-buffer marker)) |
| 170 | + (goto-char marker) |
| 171 | + (org-show-entry)) |
| 172 | + |
| 173 | +(defun helm-org-ql-show-marker-indirect (marker) |
| 174 | + "Show heading at MARKER with `org-tree-to-indirect-buffer'." |
| 175 | + (interactive) |
| 176 | + (helm-org-ql-show-marker marker) |
| 177 | + (org-tree-to-indirect-buffer)) |
| 178 | + |
| 179 | +(defun helm-org-ql-save () |
| 180 | + "Show `helm-org-ql' search in an `org-ql-search' buffer." |
| 181 | + (interactive) |
| 182 | + (let ((buffers-files (with-current-buffer (helm-buffer-get) |
| 183 | + helm-org-ql-buffers-files)) |
| 184 | + (query (helm-org-ql--input-to-query helm-pattern))) |
| 185 | + (helm-run-after-exit #'org-ql-search buffers-files query))) |
| 186 | + |
| 187 | +;;;; Functions |
| 188 | + |
| 189 | +(defun helm-org-ql--input-to-query (input &optional no-and) |
| 190 | + "Return `org-ql' query sexp for string INPUT. |
| 191 | +Unless NO-AND is non-nil (interactively, with prefix), all query |
| 192 | +tokens are wrapped in an implied (and) form, and plain |
| 193 | +symbols (except at the beginning of a sexp) are replaced with |
| 194 | +strings." |
| 195 | + (unless (s-blank-str? input) |
| 196 | + (setf input (format "(%s %s)" (if no-and "or" "and") input)) |
| 197 | + (when-let* ((query (ignore-errors |
| 198 | + ;; Ignore errors in case input is an |
| 199 | + ;; incomplete string or sexp. |
| 200 | + (read input)))) |
| 201 | + (cl-labels ((rec (form) |
| 202 | + ;; Replace some symbols with strings so users don't |
| 203 | + ;; have to type quotation marks around all strings. |
| 204 | + ;; Not perfect, but should be more useful. |
| 205 | + (pcase-exhaustive form |
| 206 | + ((pred stringp) form) |
| 207 | + (`(deadline auto) form) |
| 208 | + ((or '> '>= '< '<= '=) |
| 209 | + ;; Comparators, probably for (priority). |
| 210 | + form) |
| 211 | + ((guard (string-match (rx bos ":" (1+ anything) ":" eos) |
| 212 | + (prin1-to-string form))) |
| 213 | + ;; An Org tag, not a Lisp keyword. |
| 214 | + (prin1-to-string form)) |
| 215 | + ((pred keywordp) form) |
| 216 | + ((pred numberp) form) |
| 217 | + ((guard (string-prefix-p "!" (prin1-to-string form))) |
| 218 | + ;; Negation of a string. |
| 219 | + `(not ,(substring (prin1-to-string form) 1))) |
| 220 | + ((pred atom) (prin1-to-string form)) |
| 221 | + ((pred listp) `(,(car form) |
| 222 | + ,@(mapcar #'rec (cdr form))))))) |
| 223 | + (rec query))))) |
| 224 | + |
| 225 | +(defun helm-org-ql--heading (window-width) |
| 226 | + "Return string for Helm for heading at point. |
| 227 | +WINDOW-WIDTH should be the width of the Helm window." |
| 228 | + (font-lock-ensure (point-at-bol) (point-at-eol)) |
| 229 | + ;; TODO: It would be better to avoid calculating the prefix and width |
| 230 | + ;; at each heading, but there's no easy way to do that once in each |
| 231 | + ;; buffer, unless we manually called `org-ql' in each buffer, which |
| 232 | + ;; I'd prefer not to do. Maybe I should add a feature to `org-ql' to |
| 233 | + ;; call a setup function in a buffer before running queries. |
| 234 | + (let* ((prefix (concat (buffer-name) ":")) |
| 235 | + (width (- window-width (length prefix))) |
| 236 | + (path (org-split-string (org-format-outline-path (org-get-outline-path) |
| 237 | + width nil " ") |
| 238 | + " ")) |
| 239 | + (heading (org-get-heading t)) |
| 240 | + (path (if helm-org-ql-reverse-paths |
| 241 | + (concat heading "\\" (s-join "\\" (nreverse path))) |
| 242 | + (concat (s-join "/" path) "/" heading)))) |
| 243 | + (cons (concat prefix path) (point-marker)))) |
| 244 | + |
| 245 | +;;;; Footer |
| 246 | + |
| 247 | +(provide 'helm-org-ql) |
| 248 | + |
| 249 | +;;; helm-org-ql.el ends here |
0 commit comments