diff --git a/notes.org b/notes.org index 56b374c..33402ae 100644 --- a/notes.org +++ b/notes.org @@ -2485,3 +2485,96 @@ Benchmark results: | uncached | slowest | 3.386679 | 0 | 0 | +** Padding to-do keywords + +Not sure if these results are quite right. =elp-profile= shows them being nearly identical. + +#+BEGIN_SRC elisp + (bench-multi-lexical :times 1 + :forms (("No padding" (org-ql-agenda + (and (todo) + (not (done)) + (tags "Emacs")) + :sort (priority deadline) + :super-groups t)) + ("Padding" (org-ql-agenda** + (and (todo) + (not (done)) + (tags "Emacs")) + :sort (priority deadline) + :super-groups t)))) +#+END_SRC + +#+RESULTS: +| Form | x faster than next | Total runtime | # of GCs | Total GC runtime | +|------------+--------------------+---------------+----------+------------------| +| No padding | 1.24 | 3.990292 | 0 | 0 | +| Padding | slowest | 4.962510 | 1 | 0.731848 | + +#+BEGIN_SRC elisp + (elp-profile 5 '(format s- org-ql-) + (org-ql-agenda + (and (todo) + (not (done)) + (tags "Emacs")) + :sort (priority deadline) + :super-groups t)) +#+END_SRC + +#+RESULTS: +| Function | Times called | Total time | Average time | +|-------------------------------------+--------------+--------------+--------------| +| org-ql-agenda--agenda | 5 | 26.580556158 | 5.3161112316 | +| org-ql-select | 5 | 19.675620106 | 3.9351240212 | +| org-ql--select-cached | 40 | 19.634117127 | 0.4908529281 | +| org-ql--select | 40 | 19.630597547 | 0.4907649386 | +| org-ql--predicate-tags | 7315 | 10.949397690 | 0.0014968417 | +| org-ql--get-tags | 7315 | 9.6837818669 | 0.0013238252 | +| org-ql--predicate-todo | 48230 | 3.5819731560 | 7.426...e-05 | +| org-ql-agenda--format-element | 2435 | 3.019326507 | 0.0012399698 | +| org-ql--predicate-done | 11530 | 1.0185417590 | 8.833...e-05 | +| format | 23465 | 0.7703946220 | 3.283...e-05 | +| s-join | 5050 | 0.0558378950 | 1.105...e-05 | +| org-ql-agenda--add-faces | 2435 | 0.0284022579 | 1.166...e-05 | +| org-ql--sort-by | 5 | 0.0263453159 | 0.0052690631 | +| org-ql-agenda--add-scheduled-face | 2435 | 0.0208554550 | 8.564...e-06 | +| org-ql--priority< | 12372 | 0.0069503440 | 5.617...e-07 | +| format-time-string | 244 | 0.0062056230 | 2.543...e-05 | +| org-ql-agenda--header-line-format | 5 | 0.0058773409 | 0.0011754682 | +| org-ql-agenda--add-todo-face | 2435 | 0.0056749869 | 2.330...e-06 | +| org-ql-agenda--font-lock-string | 10 | 0.005474521 | 0.0005474521 | +| org-ql-agenda--format-relative-date | 235 | 0.0054201809 | 2.306...e-05 | + +#+BEGIN_SRC elisp + (elp-profile 5 '(format s- org-ql-) + (org-ql-agenda** + (and (todo) + (not (done)) + (tags "Emacs")) + :sort (todo priority date) + :super-groups t)) +#+END_SRC + +#+RESULTS: +| Function | Times called | Total time | Average time | +|-------------------------------------+--------------+--------------+--------------| +| org-ql-agenda--agenda** | 5 | 26.333809735 | 5.266761947 | +| org-ql-select | 5 | 17.267948398 | 3.4535896797 | +| org-ql--select-cached | 40 | 17.227040189 | 0.4306760047 | +| org-ql--select | 40 | 17.223625576 | 0.4305906394 | +| org-ql--predicate-tags | 7315 | 8.9554375800 | 0.0012242566 | +| org-ql--get-tags | 7315 | 8.8911675469 | 0.0012154706 | +| org-ql-agenda--format-element* | 2435 | 3.8197904740 | 0.0015687024 | +| org-ql--predicate-todo | 48230 | 3.3793621580 | 7.006...e-05 | +| org-ql--predicate-done | 11530 | 0.9646284939 | 8.366...e-05 | +| s-join | 5050 | 0.0551078480 | 1.091...e-05 | +| format | 30100 | 0.0522020250 | 1.734...e-06 | +| org-ql-agenda--add-faces | 2435 | 0.0287117619 | 1.179...e-05 | +| org-ql--sort-by | 5 | 0.0257972720 | 0.0051594544 | +| org-ql-agenda--add-scheduled-face | 2435 | 0.0209146540 | 8.589...e-06 | +| org-ql--priority< | 12372 | 0.0069437200 | 5.612...e-07 | +| format-time-string | 244 | 0.0061829569 | 2.533...e-05 | +| org-ql-agenda--header-line-format | 5 | 0.0058565250 | 0.001171305 | +| org-ql-agenda--add-todo-face | 2435 | 0.0056821220 | 2.333...e-06 | +| org-ql-agenda--font-lock-string | 10 | 0.005448187 | 0.0005448187 | +| org-ql-agenda--format-relative-date | 235 | 0.0053996679 | 2.297...e-05 | diff --git a/org-ql-agenda.el b/org-ql-agenda.el index d8520ff..ef34f8e 100644 --- a/org-ql-agenda.el +++ b/org-ql-agenda.el @@ -72,6 +72,8 @@ Based on `org-agenda-mode-map'.") (defvar org-ql-block-header nil "A string to override the default header in `org-ql-block' agenda blocks.") +(defvar org-ql-todo-keyword-length nil) + ;; For refreshing results buffers. (defvar org-ql-buffers-files) (defvar org-ql-query) @@ -188,6 +190,130 @@ is used, rather than binding it locally." :super-groups ',super-groups :title ,title)))) +(cl-defmacro org-ql-agenda* (&rest args) + "Display an agenda-like buffer of entries in FILES that match QUERY. + +FILES-OR-QUERY is a sexp that is evaluated to get the list of +buffers and files to scan. + +QUERY is an `org-ql' query. The query may be passed as +FILES-OR-QUERY and QUERY may be left nil, in which case the list +of files will automatically be set to the value of calling +`org-agenda-files'. + +SORT is passed to `org-ql', which see.. + +NARROW, when non-nil, means to respect narrowing in buffers. +When nil, buffers are widened before being searched. + +BUFFER, when non-nil, is a buffer or buffer name to display the +agenda in, rather than the default. + +SUPER-GROUPS is used to bind variable `org-super-agenda-groups', +which see. If t, the existing value of `org-super-agenda-groups' +is used, rather than binding it locally." + (declare (indent defun) + (advertised-calling-convention (files-or-query &optional query &key sort narrow buffer super-groups) nil)) + (cl-macrolet ((set-keyword-args (args) + `(setq sort (plist-get ,args :sort) + narrow (plist-get ,args :narrow) + buffer (plist-get ,args :buffer) + super-groups (plist-get ,args :super-groups)))) + (let ((files '(org-agenda-files)) + query sort narrow buffer super-groups) + ;; Parse args manually (so we can leave FILES nil for a default argument). + ;; TODO: DRY this and org-ql, I think. + (pcase args + (`(,arg-files ,arg-pred . ,(and rest (guard (keywordp (car rest))))) + ;; Files, query, and keyword args (FIXME: Can I combine this and the next one? Does it + ;; matter if rest is nil or starts with a keyword?) + (setq files arg-files + query arg-pred) + (set-keyword-args rest)) + (`(,arg-pred . ,(and rest (guard (keywordp (car rest))))) + ;; Query and keyword args, no files + (setq query arg-pred) + (set-keyword-args rest)) + (`(,arg-files ,arg-pred) + ;; Files and query, no keywords + (setq files arg-files + query arg-pred)) + (`(,arg-pred) + ;; Only query + (setq query arg-pred))) + (when (eq super-groups t) + (setq super-groups org-super-agenda-groups)) + ;; Call --agenda + `(org-ql-agenda--agenda* ,files + ;; TODO: Probably better to just use eval on org-ql rather than reimplementing parts of it here. + ',query + :sort ',sort + :buffer ,buffer + :narrow ,narrow + :super-groups ',super-groups)))) + +(cl-defmacro org-ql-agenda** (&rest args) + "Display an agenda-like buffer of entries in FILES that match QUERY. + +FILES-OR-QUERY is a sexp that is evaluated to get the list of +buffers and files to scan. + +QUERY is an `org-ql' query. The query may be passed as +FILES-OR-QUERY and QUERY may be left nil, in which case the list +of files will automatically be set to the value of calling +`org-agenda-files'. + +SORT is passed to `org-ql', which see.. + +NARROW, when non-nil, means to respect narrowing in buffers. +When nil, buffers are widened before being searched. + +BUFFER, when non-nil, is a buffer or buffer name to display the +agenda in, rather than the default. + +SUPER-GROUPS is used to bind variable `org-super-agenda-groups', +which see. If t, the existing value of `org-super-agenda-groups' +is used, rather than binding it locally." + (declare (indent defun) + (advertised-calling-convention (files-or-query &optional query &key sort narrow buffer super-groups) nil)) + (cl-macrolet ((set-keyword-args (args) + `(setq sort (plist-get ,args :sort) + narrow (plist-get ,args :narrow) + buffer (plist-get ,args :buffer) + super-groups (plist-get ,args :super-groups)))) + (let ((files '(org-agenda-files)) + query sort narrow buffer super-groups) + ;; Parse args manually (so we can leave FILES nil for a default argument). + ;; TODO: DRY this and org-ql, I think. + (pcase args + (`(,arg-files ,arg-pred . ,(and rest (guard (keywordp (car rest))))) + ;; Files, query, and keyword args (FIXME: Can I combine this and the next one? Does it + ;; matter if rest is nil or starts with a keyword?) + (setq files arg-files + query arg-pred) + (set-keyword-args rest)) + (`(,arg-pred . ,(and rest (guard (keywordp (car rest))))) + ;; Query and keyword args, no files + (setq query arg-pred) + (set-keyword-args rest)) + (`(,arg-files ,arg-pred) + ;; Files and query, no keywords + (setq files arg-files + query arg-pred)) + (`(,arg-pred) + ;; Only query + (setq query arg-pred))) + (when (eq super-groups t) + (setq super-groups org-super-agenda-groups)) + ;; Call --agenda + `(org-ql-agenda--agenda** ,files + ;; TODO: Probably better to just use eval on org-ql rather than reimplementing parts of it here. + ',query + :sort ',sort + :buffer ,buffer + :narrow ,narrow + :super-groups ',super-groups)))) + ;;;; Commands ;; TODO: This is called `org-ql-search' but it's in org-ql-agenda.el because @@ -409,6 +535,109 @@ Runs `org-occur-hook' after making the sparse tree." (org-agenda-finalize) (goto-char (point-min))))) +(cl-defun org-ql-agenda--agenda* (buffers-files query &key entries sort buffer narrow super-groups) + "FIXME: Docstring" + (declare (indent defun)) + (when (and super-groups (not org-super-agenda-mode)) + (user-error "`org-super-agenda-mode' must be activated to use grouping")) + (let* ((org-super-agenda-groups super-groups) + (entries (or entries + (--> (org-ql-select buffers-files + query + :sort sort + :narrow narrow + :action (lambda () + (->> (org-element-headline-parser (line-end-position)) + org-ql--add-markers)))))) + (org-ql-todo-keyword-length (cl-loop for e in entries + for todo-keyword = (org-element-property :todo-keyword e) + when todo-keyword + maximizing (length todo-keyword))) + (string (--> entries + (mapcar #'org-ql-agenda--format-element* it) + (cond ((bound-and-true-p org-super-agenda-mode) (org-super-agenda--group-items it)) + (t it)) + (s-join "\n" it))) + (buffer (cl-etypecase buffer + (string (org-ql-agenda--buffer buffer)) + (null (org-ql-agenda--buffer buffer)) + (buffer buffer))) + (map (copy-keymap org-agenda-mode-map)) + (inhibit-read-only t)) + (define-key map "g" #'org-ql-search-refresh) + (with-current-buffer buffer + (use-local-map map) + ;; Prepare buffer, saving data for refreshing. + (setq-local org-ql-buffers-files buffers-files) + (setq-local org-ql-query query) + (setq-local org-ql-sort sort) + (setq-local org-ql-narrow narrow) + (setq-local org-ql-super-groups super-groups) + (setq-local header-line-format (org-ql-agenda--header-line-format buffers-files query)) + ;; Clear buffer, insert entries, etc. + (erase-buffer) + (insert string) + (pop-to-buffer (current-buffer)) + (org-agenda-finalize) + (goto-char (point-min))))) + +(defun org-ql-agenda-todo-keyword-max-length () + "FIXME: Docstring." + (->> org-todo-keywords + (-map #'cdr) + -flatten + (--remove (string= "|" it)) + (--map (progn + (string-match (rx (1+ (not (in "(")))) it) + (length (match-string 0 it)))) + (apply #'max))) + +(defvar org-ql-agenda-todo-format) + +(cl-defun org-ql-agenda--agenda** (buffers-files query &key entries sort buffer narrow super-groups) + "FIXME: Docstring" + (declare (indent defun)) + (when (and super-groups (not org-super-agenda-mode)) + (user-error "`org-super-agenda-mode' must be activated to use grouping")) + (let* ((org-super-agenda-groups super-groups) + (entries (or entries + (--> (org-ql-select buffers-files + query + :sort sort + :narrow narrow + :action (lambda () + (->> (org-element-headline-parser (line-end-position)) + org-ql--add-markers)))))) + (org-ql-todo-keyword-length (org-ql-agenda-todo-keyword-max-length)) + (org-ql-agenda-todo-format (concat "%" (number-to-string org-ql-todo-keyword-length) "s")) + (string (--> entries + (mapcar #'org-ql-agenda--format-element* it) + (cond ((bound-and-true-p org-super-agenda-mode) (org-super-agenda--group-items it)) + (t it)) + (s-join "\n" it))) + (buffer (cl-etypecase buffer + (string (org-ql-agenda--buffer buffer)) + (null (org-ql-agenda--buffer buffer)) + (buffer buffer))) + (map (copy-keymap org-agenda-mode-map)) + (inhibit-read-only t)) + (define-key map "g" #'org-ql-search-refresh) + (with-current-buffer buffer + (use-local-map map) + ;; Prepare buffer, saving data for refreshing. + (setq-local org-ql-buffers-files buffers-files) + (setq-local org-ql-query query) + (setq-local org-ql-sort sort) + (setq-local org-ql-narrow narrow) + (setq-local org-ql-super-groups super-groups) + (setq-local header-line-format (org-ql-agenda--header-line-format buffers-files query)) + ;; Clear buffer, insert entries, etc. + (erase-buffer) + (insert string) + (pop-to-buffer (current-buffer)) + (org-agenda-finalize) + (goto-char (point-min))))) + (defun org-ql-agenda-block (query) "Insert items for QUERY into current buffer. QUERY should be an `org-ql' query form. Intended to be used as a @@ -576,6 +805,83 @@ return an empty string." 'tags tag-list 'org-habit-p habit-property))))) +(defun org-ql-agenda--format-element* (element) + ;; This essentially needs to do what `org-agenda-format-item' does, + ;; which is a lot. We are a long way from that, but it's a start. + "Return ELEMENT as a string with text-properties set by its property list. +Its property list should be the second item in the list, as +returned by `org-element-parse-buffer'. If ELEMENT is nil, +return an empty string." + (if (not element) + "" + (let* ((properties (cadr element)) + ;; Remove the :parent property, which so bloats the size of + ;; the properties list that it makes it essentially + ;; impossible to debug, because Emacs takes approximately + ;; forever to show it in the minibuffer or with + ;; `describe-text-properties'. FIXME: Shouldn't be necessary + ;; anymore since we're not parsing the whole buffer. + + ;; Also, remove ":" from key symbols. FIXME: It would be + ;; better to avoid this somehow. At least, we should use a + ;; function to convert plists to alists, if possible. + (properties (cl-loop for (key val) on properties by #'cddr + for symbol = (intern (cl-subseq (symbol-name key) 1)) + unless (member symbol '(parent)) + append (list symbol val))) + ;; TODO: --add-faces is used to add the :relative-due-date property, but that fact is + ;; hidden by doing it through --add-faces (which calls --add-scheduled-face and + ;; --add-deadline-face), and doing it in this form that gets the title hides it even more. + ;; Adding the relative due date property should probably be done explicitly and separately + ;; (which would also make it easier to do it independently of faces, etc). + (title (--> (org-ql-agenda--add-faces element) + (org-element-property :raw-value it) + (org-link-display-format it))) + (todo-keyword (-some--> (org-element-property :todo-keyword element) + (org-ql-agenda--add-todo-face it) + (format org-ql-agenda-todo-format it))) + ;; FIXME: Figure out whether I should use `org-agenda-use-tag-inheritance' or `org-use-tag-inheritance', etc. + (tag-list (if org-use-tag-inheritance + ;; FIXME: Note that tag inheritance cannot be used here unless markers are + ;; added, otherwise we can't go to the item's buffer to look for inherited + ;; tags. (Or does `org-element-headline-parser' parse inherited tags too? I + ;; forget...) + (if-let ((marker (or (org-element-property :org-hd-marker element) + (org-element-property :org-marker element)))) + (with-current-buffer (marker-buffer marker) + ;; I wish `org-get-tags' used the correct buffer automatically. + (org-get-tags marker (not org-use-tag-inheritance))) + ;; No marker found + (warn "No marker found for item: %s" title) + (org-element-property :tags element)) + (org-element-property :tags element))) + (tag-string (when tag-list + (--> tag-list + (s-join ":" it) + (s-wrap it ":") + (org-add-props it nil 'face 'org-tag)))) + ;; (category (org-element-property :category element)) + (priority-string (-some->> (org-element-property :priority element) + (char-to-string) + (format "[#%s]") + (org-ql-agenda--add-priority-face))) + (habit-property (org-with-point-at (org-element-property :begin element) + (when (org-is-habit-p) + (org-habit-parse-todo)))) + (due-string (pcase (org-element-property :relative-due-date element) + ('nil " ") + (string (format "%8s" (org-add-props string nil 'face 'org-ql-agenda-due-date))))) + (string (s-join " " (-non-nil (list due-string todo-keyword priority-string title tag-string))))) + (remove-list-of-text-properties 0 (length string) '(line-prefix) string) + ;; Add all the necessary properties and faces to the whole string + (--> string + ;; FIXME: Use proper prefix + (concat " " it) + (org-add-props it properties + 'todo-state todo-keyword + 'tags tag-list + 'org-habit-p habit-property))))) + (defun org-ql-agenda--add-faces (element) "Return ELEMENT with deadline and scheduled faces added." (->> element diff --git a/org-ql-search.el b/org-ql-search.el new file mode 100644 index 0000000..4cc2fb9 --- /dev/null +++ b/org-ql-search.el @@ -0,0 +1,202 @@ +;;; org-ql-search.el --- Search commands for org-ql -*- lexical-binding: t; -*- + +;; Author: Adam Porter +;; Url: https://github.com/alphapapa/org-ql + +;;; Commentary: + +;; This library is part of the package `org-ql'; it's not a standalone +;; library. It displays buffers similar to Org Agenda buffers, based +;; on `org-ql' queries. + +;;; License: + +;; 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 . + +;;; Code: + +(require 'cl-lib) + +(require 'dash) +(require 's) + +(require 'org-ql) +(require 'org-ql-view) + +;;;; Variables + +(defvar org-ql-views) + +;; From `org-super-agenda'. +(defvar org-super-agenda-mode) +(defvar org-super-agenda-groups) +(defvar org-super-agenda-auto-selector-keywords) +(declare-function org-super-agenda--group-items "ext:org-super-agenda") + +;; For refreshing results buffers. +(defvar org-ql-view-buffers-files) +(defvar org-ql-view-query) +(defvar org-ql-view-sort) +(defvar org-ql-view-narrow) +(defvar org-ql-view-super-groups) +(defvar org-ql-view-title) + +;;;; Commands + +;;;###autoload +(cl-defun org-ql-search (buffers-files query &key buffer narrow super-groups sort title) + "Read QUERY and search with `org-ql'. +Interactively, prompt for these variables: + +BUFFERS-FILES: A list of buffers and/or files to search. +Interactively, may also be: + +- `buffer': search the current buffer +- `all': search all Org buffers +- `agenda': search buffers returned by the function `org-agenda-files' +- An expression which evaluates to a list of files/buffers +- A space-separated list of file or buffer names + +SUPER-GROUPS: An `org-super-agenda' group set. See variable +`org-super-agenda-groups'. + +NARROW: When non-nil, don't widen buffers before +searching. Interactively, with prefix, leave narrowed. + +SORT: One or a list of `org-ql' sorting functions, like `date' or +`priority'. + +TITLE: An optional string displayed in the header. + +BUFFER: Optionally, a buffer or name of a buffer in which to +display the results. Set automatically when nil." + (declare (indent defun)) + (interactive (list (pcase-exhaustive (completing-read "Buffers/Files: " + (list 'buffer 'agenda 'all)) + ("agenda" (org-agenda-files)) + ("all" (--select (equal (buffer-local-value 'major-mode it) 'org-mode) + (buffer-list))) + ("buffer" (current-buffer)) + ((and form (guard (rx bos "("))) (-flatten (eval (read form)))) + (else (s-split (rx (1+ space)) else))) + (read-minibuffer "Query: ") + :narrow (eq current-prefix-arg '(4)) + :super-groups (when (bound-and-true-p org-super-agenda-auto-selector-keywords) + (pcase (completing-read "Group by: " + (append (list "Don't group" + "Global super-groups") + (cl-loop for type in org-super-agenda-auto-selector-keywords + collect (substring (symbol-name type) 6)))) + ("Global super-groups" org-super-agenda-groups) + ("Don't group" nil) + (property (list (list (intern (concat ":auto-" property))))))) + :sort (pcase (completing-read "Sort by: " + (list "Don't sort" + "date" + "deadline" + "priority" + "scheduled" + "todo")) + ("Don't sort" nil) + (sort (intern sort))))) + (let* ((results (org-ql-select buffers-files query + :action 'element-with-markers + :narrow narrow + :sort sort)) + (strings (-map #'org-ql-view--format-element results)) + ;; Bind variables for `org-ql-view--display' to set. + (org-ql-view-buffers-files buffers-files) + (org-ql-view-query query) + (org-ql-view-sort sort) + (org-ql-view-narrow narrow) + (org-ql-view-super-groups super-groups) + (org-ql-view-title title)) + (when super-groups + (setf strings (org-super-agenda--group-items strings))) + (org-ql-view--display + :buffer (or buffer + (format "*Org QL Search: %s*" + (or title + (format "%S in %S" query buffers-files)))) + :header (org-ql-view--header-line-format buffers-files query title) + :string (s-join "\n" strings)))) + +(defun org-ql-search-refresh () + "Refresh current `org-ql-search' buffer." + (interactive) + (let ((old-pos (point))) + (org-ql-search org-ql-view-buffers-files + org-ql-view-query + :sort org-ql-view-sort + :narrow org-ql-view-narrow + :super-groups org-ql-view-super-groups + :title org-ql-view-title + :buffer (current-buffer)) + (goto-char old-pos))) + +(defun org-ql-search-save () + "Save current `org-ql-search' buffer to `org-ql-views'." + (interactive) + (let* ((name (read-string "Save view as: ")) + (buffers-files-sexp (cl-etypecase org-ql-view-buffers-files + (string org-ql-view-buffers-files) + (list `(list ,@org-ql-view-buffers-files)) + (null nil))) + (function `(lambda () + (interactive) + (org-ql-search ,buffers-files-sexp + ',org-ql-view-query + :sort ',org-ql-view-sort + :narrow ,org-ql-view-narrow + :groups ',org-ql-view-super-groups + :title ,name)))) + (map-put org-ql-views name function #'equal) + (customize-set-variable 'org-ql-views org-ql-views) + (customize-mark-to-save 'org-ql-views))) + +(defun org-ql-search-block (query) + "Insert items for QUERY into current buffer. +QUERY should be an `org-ql' query form. Like other agenda block +commands, it searches files returned by function +`org-agenda-files'. Intended to be used as a user-defined +function in `org-agenda-custom-commands'. QUERY corresponds to +the `match' item in the custom command form. Inserts a newline +after the block." + (when-let* ((from (org-agenda-files nil 'ifmode)) + (items (org-ql-select from + query :action 'element-with-markers))) + ;; Not sure if calling the prepare function is necessary, but let's follow the pattern. + (org-agenda-prepare) + ;; FIXME: `org-agenda--insert-overriding-header' is from an Org version newer than + ;; I'm using. Should probably declare it as a minimum Org version after upgrading. + ;; (org-agenda--insert-overriding-header (org-ql-search--header-line-format from query)) + (insert (org-add-props (org-ql-view--header-line-format from query) + nil 'face 'org-agenda-structure) "\n") + ;; Calling `org-agenda-finalize' should be unnecessary, because in a "series" agenda, + ;; `org-agenda-multi' is bound non-nil, in which case `org-agenda-finalize' does nothing. + ;; But we do call `org-agenda-finalize-entries', which allows `org-super-agenda' to work. + (->> items + (-map #'org-ql-view--format-element) + org-agenda-finalize-entries + insert) + (insert "\n"))) + +;;;###autoload +(defalias 'org-ql-block 'org-ql-search-block) + +;;;; Footer + +(provide 'org-ql-search) + +;;; org-ql-search.el ends here diff --git a/org-ql-view.el b/org-ql-view.el new file mode 100644 index 0000000..68b9f45 --- /dev/null +++ b/org-ql-view.el @@ -0,0 +1,362 @@ +;;; org-ql-view.el --- Agenda-like view based on org-ql -*- lexical-binding: t; -*- + +;; Author: Adam Porter +;; Url: https://github.com/alphapapa/org-ql + +;;; Commentary: + +;; This library is part of the package `org-ql'; it's not a standalone +;; library. It displays strings in buffers similar to Org Agenda +;; buffers. + +;;; License: + +;; 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 . + +;;; Code: + +(require 'cl-lib) +(require 'map) +(require 'org) +(require 'org-element) +(require 'org-agenda) +(require 'seq) +(require 'rx) + +(require 'org-ql) + +(require 'dash) +(require 's) + +;;;; Compatibility + +(defvar org-super-agenda-auto-selector-keywords) +(defvar org-super-agenda-groups) +(defvar org-super-agenda-mode) +(declare-function org-super-agenda--group-items "ext:org-super-agenda") + +(when (version< org-version "9.2") + (defalias 'org-get-tags #'org-get-tags-at)) + +;;;; Faces + +(defface org-ql-view-due-date + '((t (:slant italic :weight bold))) + "Face for due dates in `org-ql-view' views." + :group 'org-ql) + +;;;; Variables + +(defvar org-ql-view-buffer-name "*Org-QL View*" + "Name of default `org-ql-view' buffer.") + +(defvar org-ql-view-map + ;; FIXME: Discrepancy between org-ql-search and org-ql-view here. + (let ((map (copy-keymap org-agenda-mode-map))) + (define-key map "g" #'org-ql-search-refresh) + (define-key map (kbd "C-x C-s") #'org-ql-search-save) + map) + "Keymap for `org-ql-view', `org-ql-search', and `org-ql-views' views. +Based on `org-agenda-mode-map'.") + +;; For refreshing results buffers. +(defvar-local org-ql-view-buffers-files nil) +(defvar-local org-ql-view-query nil) +(defvar-local org-ql-view-sort nil) +(defvar-local org-ql-view-narrow nil) +(defvar-local org-ql-view-super-groups nil) +(defvar-local org-ql-view-title nil) + +;;;; Functions + +(cl-defun org-ql-view--display (&key buffer header string) + "Display STRING in `org-ql-view' BUFFER. + +BUFFER may be a buffer, or a string naming a buffer, which is +reused if it already exists. + +HEADER is a string displayed in the buffer's header line. + +The following special variables, if non-nil, are set +buffer-locally to preserve their value in the buffer for +subsequent refreshing of the buffer: `org-ql-view-buffers-files', +`org-ql-view-query', `org-ql-view-sort', `org-ql-view-narrow', +`org-ql-view-super-groups', `org-ql-title.'" + ;; TODO: Rename `entries' to `elements'. + (declare (indent defun)) + (let* ((buffer (cl-etypecase buffer + (string (org-ql-view--buffer buffer)) + (null (org-ql-view--buffer buffer)) + (buffer buffer)))) + (with-current-buffer buffer + (use-local-map org-ql-view-map) + ;; Prepare buffer, saving data for refreshing. + (cl-loop for symbol in (list 'org-ql-view-buffers-files 'org-ql-view-query + 'org-ql-view-sort 'org-ql-view-narrow + 'org-ql-view-super-groups 'org-ql-view-title) + do (set (make-local-variable symbol) (symbol-value symbol))) + (setq-local header-line-format header) + ;; Clear buffer, insert entries, etc. + (let ((inhibit-read-only t)) + (erase-buffer) + (insert string) + (pop-to-buffer (current-buffer)) + (org-agenda-finalize) + (goto-char (point-min)))))) + +(defun org-ql-view--header-line-format (buffers-files query &optional title) + "Return header-line-format for BUFFERS-FILES and QUERY." + (let* ((title (if title + (concat (propertize "View:" 'face 'org-agenda-structure) + title " ") + "")) + (query-formatted (format "%S" query)) + (query-formatted (propertize (org-ql-view--font-lock-string 'emacs-lisp-mode query-formatted) + 'help-echo query-formatted)) + (query-width (length query-formatted)) + (available-width (max 0 (- (window-width) + (length "In: ") + (length "Query: ") + query-width 4))) + (buffers-files-formatted (format "%S" buffers-files)) + (buffers-files-formatted (propertize (->> buffers-files-formatted + (org-ql-view--font-lock-string 'emacs-lisp-mode) + (s-truncate available-width)) + 'help-echo buffers-files-formatted))) + (concat title + (propertize "Query:" 'face 'org-agenda-structure) + query-formatted " " + (propertize "In:" 'face 'org-agenda-structure) + buffers-files-formatted))) + +(defun org-ql-view--font-lock-string (mode s) + "Return string S font-locked according to MODE." + ;; FIXME: Is this the proper way to do this? It works, but I feel like there must be a built-in way... + (with-temp-buffer + (delay-mode-hooks + (insert s) + (funcall mode) + (font-lock-ensure) + (buffer-string)))) + +(defun org-ql-view--buffer (&optional name) + "Return Agenda NG buffer, creating it if necessary. +If NAME is non-nil, return buffer by that name instead of using +default buffer." + (with-current-buffer (get-buffer-create (or name org-ql-view-buffer-name)) + (unless (eq major-mode 'org-agenda-mode) + (org-agenda-mode)) + (current-buffer))) + +(defun org-ql-view--format-relative-date (difference) + ;; MAYBE: Make this a `defsubst'. + "Return relative date string for DIFFERENCE. +DIFFERENCE should be an integer number of days, positive for +dates in the past, and negative for dates in the future." + (cond ((> difference 0) + (format "%sd ago" difference)) + ((< difference 0) + (format "in %sd" (* -1 difference))) + (t "today"))) + +;;;; Faces/properties + +(defun org-ql-view--format-element (element) + ;; This essentially needs to do what `org-agenda-format-item' does, + ;; which is a lot. We are a long way from that, but it's a start. + "Return ELEMENT as a string with text-properties set by its property list. +Its property list should be the second item in the list, as +returned by `org-element-parse-buffer'. If ELEMENT is nil, +return an empty string." + (if (not element) + "" + (let* ((properties (cadr element)) + ;; Remove the :parent property, which so bloats the size of + ;; the properties list that it makes it essentially + ;; impossible to debug, because Emacs takes approximately + ;; forever to show it in the minibuffer or with + ;; `describe-text-properties'. FIXME: Shouldn't be necessary + ;; anymore since we're not parsing the whole buffer. + + ;; Also, remove ":" from key symbols. FIXME: It would be + ;; better to avoid this somehow. At least, we should use a + ;; function to convert plists to alists, if possible. + (properties (cl-loop for (key val) on properties by #'cddr + for symbol = (intern (cl-subseq (symbol-name key) 1)) + unless (member symbol '(parent)) + append (list symbol val))) + ;; TODO: --add-faces is used to add the :relative-due-date property, but that fact is + ;; hidden by doing it through --add-faces (which calls --add-scheduled-face and + ;; --add-deadline-face), and doing it in this form that gets the title hides it even more. + ;; Adding the relative due date property should probably be done explicitly and separately + ;; (which would also make it easier to do it independently of faces, etc). + (title (--> (org-ql-view--add-faces element) + (org-element-property :raw-value it) + (org-link-display-format it))) + (todo-keyword (-some--> (org-element-property :todo-keyword element) + (org-ql-view--add-todo-face it))) + ;; FIXME: Figure out whether I should use `org-agenda-use-tag-inheritance' or `org-use-tag-inheritance', etc. + (tag-list (if org-use-tag-inheritance + ;; FIXME: Note that tag inheritance cannot be used here unless markers are + ;; added, otherwise we can't go to the item's buffer to look for inherited + ;; tags. (Or does `org-element-headline-parser' parse inherited tags too? I + ;; forget...) + (if-let ((marker (or (org-element-property :org-hd-marker element) + (org-element-property :org-marker element)))) + (with-current-buffer (marker-buffer marker) + ;; I wish `org-get-tags' used the correct buffer automatically. + (org-get-tags marker (not org-use-tag-inheritance))) + ;; No marker found + (warn "No marker found for item: %s" title) + (org-element-property :tags element)) + (org-element-property :tags element))) + (tag-string (when tag-list + (--> tag-list + (s-join ":" it) + (s-wrap it ":") + (org-add-props it nil 'face 'org-tag)))) + ;; (category (org-element-property :category element)) + (priority-string (-some->> (org-element-property :priority element) + (char-to-string) + (format "[#%s]") + (org-ql-view--add-priority-face))) + (habit-property (org-with-point-at (org-element-property :begin element) + (when (org-is-habit-p) + (org-habit-parse-todo)))) + (due-string (pcase (org-element-property :relative-due-date element) + ('nil "") + (string (format " %s " (org-add-props string nil 'face 'org-ql-view-due-date))))) + (string (s-join " " (-non-nil (list todo-keyword priority-string title due-string tag-string))))) + (remove-list-of-text-properties 0 (length string) '(line-prefix) string) + ;; Add all the necessary properties and faces to the whole string + (--> string + ;; FIXME: Use proper prefix + (concat " " it) + (org-add-props it properties + 'todo-state todo-keyword + 'tags tag-list + 'org-habit-p habit-property))))) + +(defun org-ql-view--add-faces (element) + "Return ELEMENT with deadline and scheduled faces added." + (->> element + (org-ql-view--add-scheduled-face) + (org-ql-view--add-deadline-face))) + +(defun org-ql-view--add-priority-face (string) + "Return STRING with priority face added." + (when (string-match "\\(\\[#\\(.\\)\\]\\)" string) + (let ((face (org-get-priority-face (string-to-char (match-string 2 string))))) + (org-add-props string nil 'face face 'font-lock-fontified t)))) + +(defun org-ql-view--add-scheduled-face (element) + "Add faces to ELEMENT's title for its scheduled status." + ;; NOTE: Also adding prefix + (if-let ((scheduled-date (org-element-property :scheduled element))) + (let* ((todo-keyword (org-element-property :todo-keyword element)) + (today-day-number (org-today)) + ;; (current-day-number + ;; NOTE: Not currently used, but if we ever implement a more "traditional" agenda that + ;; shows perspective of multiple days at once, we'll need this, so I'll leave it for now. + ;; ;; FIXME: This is supposed to be the, shall we say, + ;; ;; pretend, or perspective, day number that this pass + ;; ;; through the agenda is being made for. We need to + ;; ;; either set this in the calling function, set it here, + ;; ;; or accomplish this in a different way. See + ;; ;; `org-agenda-get-scheduled' and where `date' is set in + ;; ;; `org-agenda-list'. + ;; today-day-number) + (scheduled-day-number (org-time-string-to-absolute + (org-element-timestamp-interpreter scheduled-date 'ignore))) + (difference-days (- today-day-number scheduled-day-number)) + (relative-due-date (org-add-props (org-ql-view--format-relative-date difference-days) nil + 'help-echo (org-element-property :raw-value scheduled-date))) + ;; FIXME: Unused for now: + ;; (show-all (or (eq org-agenda-repeating-timestamp-show-all t) + ;; (member todo-keyword org-agenda-repeating-timestamp-show-all))) + ;; FIXME: Unused for now: (sexp-p (string-prefix-p "%%" raw-value)) + ;; FIXME: Unused for now: (raw-value (org-element-property :raw-value scheduled-date)) + ;; FIXME: I don't remember what `repeat-day-number' was for, but we aren't using it. + ;; But I'll leave it here for now. + ;; (repeat-day-number (cond (sexp-p (org-time-string-to-absolute scheduled-date)) + ;; ((< today-day-number scheduled-day-number) scheduled-day-number) + ;; (t (org-time-string-to-absolute + ;; raw-value + ;; (if show-all + ;; current-day-number + ;; today-day-number) + ;; 'future + ;; ;; FIXME: I don't like + ;; ;; calling `current-buffer' + ;; ;; here. If the element has + ;; ;; a marker, we should use + ;; ;; that. + ;; (current-buffer) + ;; (org-element-property :begin element))))) + (face (cond ((member todo-keyword org-done-keywords) 'org-agenda-done) + ((= today-day-number scheduled-day-number) 'org-scheduled-today) + ((> today-day-number scheduled-day-number) 'org-scheduled-previously) + (t 'org-scheduled))) + (title (--> (org-element-property :raw-value element) + (org-add-props it nil + 'face face))) + (properties (--> (cadr element) + (plist-put it :title title) + (plist-put it :relative-due-date relative-due-date)))) + (list (car element) + properties)) + ;; Not scheduled + element)) + +(defun org-ql-view--add-deadline-face (element) + "Add faces to ELEMENT's title for its deadline status. +Also store relative due date as string in `:relative-due-date' +property." + ;; FIXME: In my config, doesn't apply orange for approaching deadline the same way the Org Agenda does. + (if-let ((deadline-date (org-element-property :deadline element))) + (let* ((today-day-number (org-today)) + (deadline-day-number (org-time-string-to-absolute + (org-element-timestamp-interpreter deadline-date 'ignore))) + (difference-days (- today-day-number deadline-day-number)) + (relative-due-date (org-add-props (org-ql-view--format-relative-date difference-days) nil + 'help-echo (org-element-property :raw-value deadline-date))) + ;; FIXME: Unused for now: (todo-keyword (org-element-property :todo-keyword element)) + ;; FIXME: Unused for now: (done-p (member todo-keyword org-done-keywords)) + ;; FIXME: Unused for now: (today-p (= today-day-number deadline-day-number)) + (deadline-passed-fraction (--> (- deadline-day-number today-day-number) + (float it) + (/ it (max org-deadline-warning-days 1)) + (- 1 it))) + (face (org-agenda-deadline-face deadline-passed-fraction)) + (title (--> (org-element-property :raw-value element) + (org-add-props it nil + 'face face))) + (properties (--> (cadr element) + (plist-put it :title title) + (plist-put it :relative-due-date relative-due-date)))) + (list (car element) + properties)) + ;; No deadline + element)) + +(defun org-ql-view--add-todo-face (keyword) + "Return KEYWORD with TODO face added." + (when-let ((face (org-get-todo-face keyword))) + (org-add-props keyword nil 'face face))) + +;;;; Footer + +(provide 'org-ql-view) + +;;; org-ql-view.el ends here