From ab91209e2c7082cf4fcbf2a4154fea24e2b19268 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Mon, 30 Aug 2021 22:27:44 -0500 Subject: [PATCH 01/29] WIP: taxy-org-ql-view Moving from the taxy.el.git repo. --- taxy-org-ql-view.el | 274 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 274 insertions(+) create mode 100644 taxy-org-ql-view.el diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el new file mode 100644 index 0000000..a489f7c --- /dev/null +++ b/taxy-org-ql-view.el @@ -0,0 +1,274 @@ +;;; taxy-org-ql-view.el --- -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Adam Porter + +;; Author: Adam Porter +;; Keywords: + +;; 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: + +;; + +;;; Code: + +;;;; Requirements + +(require 'map) +(require 'seq) + +(require 'org-ql-view) + +(require 'taxy) +(require 'taxy-magit-section) + +;;;; Structs + +(cl-defstruct (taxy-org-ql-view-section + (:include taxy-magit-section + (format-fn #'org-ql-view--format-element) + (indent 2) + (make #'make-taxy-org-ql-view-section)))) + +;;;; Macros + +;;;; Defining taxy keys with macro + +(defvar taxy-org-ql-view-keys nil) + +(defmacro taxy-org-ql-view-define-key (name args &rest body) + "Define a `taxy-org-ql-view' key function by NAME having BODY taking ARGS. +Within BODY, `element' is bound to the `org-element' element +being tested. + +Defines a function named `taxy-org-ql--predicate-NAME', and adds +an entry to `taxy-org-ql-view-keys' mapping NAME to the new +function symbol." + (declare (indent defun) + (debug (&define symbolp listp &rest def-form))) + (let* ((fn-symbol (intern (format "taxy-org-ql--predicate-%s" name))) + (fn `(lambda (element ,@args) + ,@body))) + `(progn + (fset ',fn-symbol ,fn) + (setf (map-elt taxy-org-ql-view-keys ',name) ',fn-symbol)))) + +(taxy-org-ql-view-define-key heading (&rest strings) + "Return STRINGS that ELEMENT's heading matches." + (when-let ((matches (cl-loop with heading = (org-element-property :raw-value element) + for string in strings + when (string-match (regexp-quote string) heading) + collect string))) + (format "Heading: %s" (string-join matches ", ")))) + +(taxy-org-ql-view-define-key todo (&optional keyword) + "Return the to-do keyword for ELEMENT. +If KEYWORD, return whether it matches that." + (when-let ((element-keyword (org-element-property :todo-keyword element))) + (cl-flet ((format-keyword + (keyword) (format "To-do: %s" keyword))) + (pcase keyword + ('nil (format-keyword element-keyword)) + (_ (pcase element-keyword + ((pred (equal keyword)) + (format-keyword element-keyword)))))))) + +(taxy-org-ql-view-define-key tags (&rest tags) + "Return the tags for ELEMENT. +If TAGS, return whether it matches them." + (cl-flet ((tags-at + (pos) (apply #'append (delq 'org-ql-nil (org-ql--tags-at pos))))) + (org-with-point-at (org-element-property :org-hd-marker element) + (pcase tags + ('nil (tags-at (point))) + (_ (when-let (common-tags (seq-intersection tags (tags-at (point)) + #'cl-equalp)) + (format "Tags: %s" (string-join common-tags ", ")))))))) + +(taxy-org-ql-view-define-key priority (&optional priority) + "Return ELEMENT's priority as a string. +If PRIORITY, return it if it matches ELEMENT's priority." + (when-let ((priority-number (org-element-property :priority element))) + (cl-flet ((format-priority + (num) (format "Priority: %s" num))) + ;; FIXME: Priority numbers may be wildly larger, right? + (pcase priority + ('nil (format-priority (char-to-string priority-number))) + (_ (pcase (char-to-string priority-number) + ((and (pred (equal priority)) string) + (format-priority string)))))))) + +(taxy-org-ql-view-define-key planning-month () + "Return ELEMENT's planning-date month, or nil. +Returns in format \"%Y-%m (%B)\"." + (when-let ((planning-element (or (org-element-property :deadline element) + (org-element-property :scheduled element) + (org-element-property :closed element)))) + (ts-format "Planning: %Y-%m (%B)" (ts-parse-org-element planning-element)))) + +(taxy-org-ql-view-define-key planning-year () + "Return ELEMENT's planning-date year, or nil. +Returns in format \"%Y\"." + (when-let ((planning-element (or (org-element-property :deadline element) + (org-element-property :scheduled element) + (org-element-property :closed element)))) + (ts-format "Planning: %Y" (ts-parse-org-element planning-element)))) + +(taxy-org-ql-view-define-key planning-date () + "Return ELEMENT's planning date, or nil. +Returns in format \"%Y-%m-%d\"." + (when-let ((planning-element (or (org-element-property :deadline element) + (org-element-property :scheduled element) + (org-element-property :closed element)))) + (ts-format "Planning: %Y-%m-%d" (ts-parse-org-element planning-element)))) + +(taxy-org-ql-view-define-key planning () + "Return \"Planned\" if ELEMENT has a planning date." + (when (or (org-element-property :deadline element) + (org-element-property :scheduled element) + (org-element-property :closed element)) + "Planned")) + +(taxy-org-ql-view-define-key deadline (&rest args) + "Return whether ELEMENT has a deadline according to ARGS." + (when-let ((deadline-element (org-element-property :deadline element))) + (pcase args + (`(,(or 'nil 't)) "Deadlined") + (_ (let ((element-ts (ts-parse-org-element deadline-element))) + (pcase args + ((and `(:past) + (guard (ts> (ts-now) element-ts))) + "Overdue") + ((and `(:today) + (guard (equal (ts-day (ts-now)) (ts-day element-ts)))) + "Due today") + ((and `(:future) + (guard (ts< (ts-now) element-ts))) + ;; FIXME: Not necessarily soon. + "Due soon") + ((and `(:before ,target-date) + (guard (ts< element-ts (ts-parse target-date)))) + (concat "Due before: " target-date)) + ((and `(:after ,target-date) + (guard (ts> element-ts (ts-parse target-date)))) + (concat "Due after: " target-date)) + ((and `(:on ,target-date) + (guard (let ((now (ts-now))) + (and (equal (ts-doy element-ts) + (ts-doy now)) + (equal (ts-year element-ts) + (ts-year now)))))) + (concat "Due on: " target-date)) + ((and `(:from ,target-ts) + (guard (ts<= (ts-parse target-ts) element-ts))) + (concat "Due from: " target-ts)) + ((and `(:to ,target-ts) + (guard (ts>= (ts-parse target-ts) element-ts))) + (concat "Due to: " target-ts)) + ((and `(:from ,from-ts :to ,to-ts) + (guard (and (ts<= (ts-parse from-ts) element-ts) + (ts>= (ts-parse to-ts) element-ts)))) + (format "Due from: %s to %s" from-ts to-ts)))))))) + +(defun taxy-org-ql-view-take-fn (keys) + "Return a `taxy' \"take\" function for KEYS. +Each of KEYS should be a function alias defined in +`taxy-org-ql-view-keys', or a list of such KEY-FNS (recursively, +ad infinitum, approximately)." + (let ((macrolets (cl-loop for (name . fn) in taxy-org-ql-view-keys + collect `(,name ',fn)))) + (cl-labels ((expand-form + ;; Is using (cadr (macroexpand-all ...)) really better than `eval'? + (form) (cadr + (macroexpand-all + `(cl-symbol-macrolet (,@macrolets) + ,form)))) + (quote-fn + (fn) (pcase fn + ((pred symbolp) fn) + (`(,(and (pred symbolp) fn) + . ,(and args (guard (cl-typecase (car args) + ((or keyword (and atom (not symbol))) + t))))) + ;; Key with args: replace with a lambda that + ;; calls that key's function with given args. + `(lambda (element) + (,(expand-form fn) element ,@args))) + ((pred listp) (cons 'list (mapcar #'quote-fn fn)))))) + (setf keys (mapcar #'quote-fn keys)) + (expand-form + `(lambda (item taxy) + (taxy-take-keyed (list ,@keys) item taxy)))))) + +(defun taxy-org-ql-view-make-taxy (name keys) + "Return a dynamic `taxy-org-ql-view-section' taxy named NAME having KEYS. +KEYS is passed to `taxy-org-ql-view-take-fn', which see." + (declare (indent defun)) + (make-taxy-org-ql-view-section + :name name + :take (taxy-org-ql-view-take-fn keys))) + +;;;; Variables + +;;;; Customization + +;;;; Commands + +;;;; Functions + +(cl-defun taxy-org-ql-search + (buffers-or-files query &key taxy-keys sort) + "Show Org QL QUERY on BUFFERS-OR-FILES with `taxy-org-ql-view'." + (declare (indent 1)) + (let* ((title (format "Query:%S In:%S" query buffers-or-files)) + (buffer-name (format "*Taxy Org QL View: %s*" title))) + (when (get-buffer buffer-name) + ;; Reusing an existing magit-section buffer seems to cause a lot + ;; of GC, so just kill it if it already exists. + (kill-buffer buffer-name)) + (with-current-buffer (get-buffer-create buffer-name) + (magit-section-mode) + (use-local-map (make-composed-keymap (list magit-section-mode-map org-ql-view-map))) + (taxy-org-ql-view--add-search buffers-or-files + query :sort sort :taxy-keys taxy-keys) + (pop-to-buffer (current-buffer))))) + +(cl-defun taxy-org-ql-view--add-search + (buffers-or-files query &key taxy-keys sort) + "Show Org QL QUERY on BUFFERS-OR-FILES with `taxy-org-ql-view'." + (declare (indent 1)) + (let* ((title (format "Query:%S In:%S" query buffers-or-files)) + (taxy (taxy-org-ql-view-make-taxy title + taxy-keys)) + (items (org-ql-select buffers-or-files query + :action 'element-with-markers + :sort sort)) ) + (let ((inhibit-read-only t)) + (save-excursion + (goto-char (point-max)) + (taxy-magit-section-insert + (thread-last taxy + (taxy-fill items) + (taxy-mapc* (lambda (taxy) + (setf (taxy-taxys taxy) + (cl-sort (taxy-taxys taxy) #'string< + :key #'taxy-name))))) + :items 'last))))) + +;;;; Footer + +(provide 'taxy-org-ql-view) + +;;; taxy-org-ql-view.el ends here From 7540e81f09e770a3d9d844888372c0cf71ca79d5 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Tue, 31 Aug 2021 03:07:50 -0500 Subject: [PATCH 02/29] WIP: Add more keys --- taxy-org-ql-view.el | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index a489f7c..258e0be 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -141,6 +141,34 @@ Returns in format \"%Y-%m-%d\"." (org-element-property :closed element)) "Planned")) +(taxy-org-ql-view-define-key category () + "Return ELEMENT's category." + (org-with-point-at (org-element-property :org-hd-marker element) + (org-get-category))) + +(defun taxy-org-ql--latest-timestamp-in (regexp element) + "Return the latest timestamp matching REGEXP in ELEMENT. +Searches in ELEMENT's buffer." + (org-with-point-at (org-element-property :org-hd-marker element) + (let* ((limit (org-entry-end-position)) + (tss (cl-loop for next-ts = + (when (re-search-forward regexp limit t) + (ts-parse-org (match-string 1))) + while next-ts + collect next-ts))) + (when tss + (car (sort tss #'ts>)))))) + +(taxy-org-ql-view-define-key ts-year () + "Return the year of ELEMENT's latest timestamp." + (when-let ((latest-ts (taxy-org-ql--latest-timestamp-in org-element--timestamp-regexp element))) + (ts-format "%Y" latest-ts))) + +(taxy-org-ql-view-define-key ts-month () + "Return the month of ELEMENT's latest timestamp." + (when-let ((latest-ts (taxy-org-ql--latest-timestamp-in org-element--timestamp-regexp element))) + (ts-format "%Y-%m (%B)" latest-ts))) + (taxy-org-ql-view-define-key deadline (&rest args) "Return whether ELEMENT has a deadline according to ARGS." (when-let ((deadline-element (org-element-property :deadline element))) From 924239ea79990a20d090d2a15a3e078c691a3751 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Thu, 9 Sep 2021 13:48:19 +0000 Subject: [PATCH 03/29] WIP: Columns --- taxy-org-ql-view.el | 196 ++++++++++++++++++++++++++++++++++++++------ 1 file changed, 173 insertions(+), 23 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 258e0be..6900897 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -38,12 +38,142 @@ (cl-defstruct (taxy-org-ql-view-section (:include taxy-magit-section - (format-fn #'org-ql-view--format-element) - (indent 2) (make #'make-taxy-org-ql-view-section)))) +;;;; Customization + +(defgroup org-ql-view-taxy nil + "Options for `org-ql-view-taxy'." + :group 'org-ql-view) + +(defcustom org-ql-view-taxy-blank-between-depth 1 + "Insert blank lines between groups up to this depth." + :type 'integer) + +(defcustom org-ql-view-taxy-initial-depth 0 + "Effective initial depth of first-level groups. +Sets at which depth groups and items begin to be indented. For +example, setting to -1 prevents indentation of the first and +second levels." + :type 'integer) + +(defcustom org-ql-view-taxy-level-indent 1 + "Indentation per level of depth." + :type 'integer) + +(defcustom org-ql-view-taxy-item-indent 1 + "Indentation of items relative to their level's indentation." + :type 'integer) + ;;;; Macros +;;;;; Columns + +(defvar org-ql-view-column-format-fns nil + "FIXME: Docstring.") + +(defvar org-ql-view-columns + '("Keyword" "Pri" "Heading" "Planning" "Tags") + "FIXME: Docstring.") + +(defmacro org-ql-view-define-column (name plist &rest body) + "Define a column formatting function with NAME. +NAME should be a string. BODY should return a string or nil. In +the BODY, `element' is bound to the Org element, and `depth' is +bound to the buffer's depth in the group tree. + +PLIST may be a plist setting the following options: + + `:face' is a face applied to the string. + + `:max-width' defines a customization option for the column's + maximum width with the specified value as its default: an + integer limits the width, while nil does not." + (declare (indent defun)) + (cl-check-type name string) + (pcase-let* ((fn-name (intern (concat "org-ql-view-column-format-" (downcase name)))) + ((map :face :max-width) plist) + (max-width-variable (intern (concat "org-ql-view-column-" name "-max-width"))) + (max-width-docstring (format "Maximum width of the %s column." name))) + `(progn + ,(when (plist-member plist :max-width) + `(defcustom ,max-width-variable + ,max-width + ,max-width-docstring + :type '(choice (integer :tag "Maximum width") + (const :tag "Unlimited width" nil)))) + (defun ,fn-name (element depth) + (if-let ((string (progn ,@body))) + (progn + ,(when max-width + `(when ,max-width-variable + (setf string (truncate-string-to-width string ,max-width-variable nil nil "…")))) + ,(when face + ;; Faces are not defined until load time, while this checks type at expansion + ;; time, so we can only test that the argument is a symbol, not a face. + (cl-check-type face symbol ":face must be a face symbol") + `(setf string (propertize string 'face ',face))) + string) + "")) + (setf (map-elt org-ql-view-column-format-fns ,name) #',fn-name)))) + +(org-ql-view-define-column "Keyword" (:max-width nil) + (let ((indentation (make-string (+ (* depth org-ql-view-taxy-level-indent) + org-ql-view-taxy-item-indent) + ? )) + (keyword (or (org-element-property :todo-keyword element) ""))) + (unless (string-empty-p keyword) + ;; NOTE: We use `substring-no-properties' to avoid propagating + ;; `wrap-prefix' and `line-prefix' properties that may be + ;; present on the source buffer's keyword. + (setf keyword (org-ql-view--add-todo-face (substring-no-properties keyword)))) + (concat indentation keyword))) + +(org-ql-view-define-column "Heading" (:max-width 60) + (ignore depth) + (org-link-display-format + (org-element-property + :raw-value (org-ql-view--add-faces element)))) + +(org-ql-view-define-column "Planning" (:max-width nil) + (ignore depth) + (when-let ((planning-element (or (org-element-property :deadline element) + (org-element-property :scheduled element) + (org-element-property :closed element)))) + (org-ql-view--format-relative-date + (floor (/ (ts-diff (ts-now) (ts-parse-org-element planning-element)) + 86400))))) + +(org-ql-view-define-column "Pri" (:max-width nil) + (ignore depth) + (or (-some->> (org-element-property :priority element) + (char-to-string) + (format "[#%s]") + (org-ql-view--add-priority-face)) + "")) + +(org-ql-view-define-column "Tags" (:max-width nil) + (ignore depth) + ;; Copied from `org-ql-view--format-element'. + (when-let ((tags (if org-use-tag-inheritance + ;; MAYBE: Use our own variable instead of `org-use-tag-inheritance'. + (if-let ((marker (or (org-element-property :org-hd-marker element) + (org-element-property :org-marker element)))) + (with-current-buffer (marker-buffer marker) + (org-with-wide-buffer + (goto-char marker) + (cl-loop for type in (org-ql--tags-at marker) + unless (or (eq 'org-ql-nil type) + (not type)) + append type))) + ;; No marker found + ;; TODO: Use `display-warning' with `org-ql' as the type. + (warn "No marker found for item: %s" element) + (org-element-property :tags element)) + (org-element-property :tags element)))) + (org-add-props (concat ":" (string-join tags ":") ":") + nil 'face 'org-tag))) + ;;;; Defining taxy keys with macro (defvar taxy-org-ql-view-keys nil) @@ -240,13 +370,14 @@ ad infinitum, approximately)." `(lambda (item taxy) (taxy-take-keyed (list ,@keys) item taxy)))))) -(defun taxy-org-ql-view-make-taxy (name keys) +(defun taxy-org-ql-view-make-taxy (name keys &rest args) "Return a dynamic `taxy-org-ql-view-section' taxy named NAME having KEYS. KEYS is passed to `taxy-org-ql-view-take-fn', which see." (declare (indent defun)) - (make-taxy-org-ql-view-section - :name name - :take (taxy-org-ql-view-take-fn keys))) + (apply #'make-taxy-org-ql-view-section + :name name + :take (taxy-org-ql-view-take-fn keys) + args)) ;;;; Variables @@ -277,23 +408,42 @@ KEYS is passed to `taxy-org-ql-view-take-fn', which see." (buffers-or-files query &key taxy-keys sort) "Show Org QL QUERY on BUFFERS-OR-FILES with `taxy-org-ql-view'." (declare (indent 1)) - (let* ((title (format "Query:%S In:%S" query buffers-or-files)) - (taxy (taxy-org-ql-view-make-taxy title - taxy-keys)) - (items (org-ql-select buffers-or-files query - :action 'element-with-markers - :sort sort)) ) - (let ((inhibit-read-only t)) - (save-excursion - (goto-char (point-max)) - (taxy-magit-section-insert - (thread-last taxy - (taxy-fill items) - (taxy-mapc* (lambda (taxy) - (setf (taxy-taxys taxy) - (cl-sort (taxy-taxys taxy) #'string< - :key #'taxy-name))))) - :items 'last))))) + (let (format-table column-sizes) + (cl-labels ((format-item (item) (gethash item format-table)) + (make-fn (&rest args) + (apply #'make-taxy-org-ql-view-section + :make #'make-fn + :format-fn #'format-item + ;; :heading-face-fn #'heading-face + :heading-indent org-ql-view-taxy-level-indent + :item-indent 0 + args))) + (let* ((title (format "Query:%S In:%S" + (org-ql--query-sexp-to-string query) buffers-or-files)) + (items (org-ql-select buffers-or-files query + :action 'element-with-markers + :sort sort)) + (taxy (thread-last (make-fn + :name title + :take (taxy-org-ql-view-take-fn taxy-keys)) + (taxy-fill items))) + (taxy-magit-section-insert-indent-items nil) + format-cons header) + ;; FIXME: Adding a search overwrites the `header-line-format'. + (setf format-cons (taxy-magit-section-format-items + org-ql-view-columns org-ql-view-column-format-fns taxy) + format-table (car format-cons) + column-sizes (cdr format-cons) + ;; NOTE: The first column is handled differently. + header (concat (format (format " %%-%ss" (cdar column-sizes)) (caar column-sizes)) + (cl-loop for (name . size) in (cdr column-sizes) + for spec = (format " %%-%ss" size) + concat (format spec name))) + header-line-format header) + (let ((inhibit-read-only t)) + (save-excursion + (goto-char (point-max)) + (taxy-magit-section-insert taxy :items 'first))))))) ;;;; Footer From daa3ab31e8b131f6fb6b410827940612a2d82d5e Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Tue, 14 Sep 2021 16:27:43 +0000 Subject: [PATCH 04/29] WIP: Updates for improvements to taxy.el --- taxy-org-ql-view.el | 423 ++++++++++++++++---------------------------- 1 file changed, 153 insertions(+), 270 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 6900897..8e9ed40 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -36,10 +36,6 @@ ;;;; Structs -(cl-defstruct (taxy-org-ql-view-section - (:include taxy-magit-section - (make #'make-taxy-org-ql-view-section)))) - ;;;; Customization (defgroup org-ql-view-taxy nil @@ -57,224 +53,156 @@ example, setting to -1 prevents indentation of the first and second levels." :type 'integer) -(defcustom org-ql-view-taxy-level-indent 1 - "Indentation per level of depth." - :type 'integer) - -(defcustom org-ql-view-taxy-item-indent 1 - "Indentation of items relative to their level's indentation." - :type 'integer) - -;;;; Macros - ;;;;; Columns -(defvar org-ql-view-column-format-fns nil - "FIXME: Docstring.") +(taxy-magit-section-define-column-definer "org-ql-view") -(defvar org-ql-view-columns - '("Keyword" "Pri" "Heading" "Planning" "Tags") - "FIXME: Docstring.") - -(defmacro org-ql-view-define-column (name plist &rest body) - "Define a column formatting function with NAME. -NAME should be a string. BODY should return a string or nil. In -the BODY, `element' is bound to the Org element, and `depth' is -bound to the buffer's depth in the group tree. - -PLIST may be a plist setting the following options: - - `:face' is a face applied to the string. - - `:max-width' defines a customization option for the column's - maximum width with the specified value as its default: an - integer limits the width, while nil does not." - (declare (indent defun)) - (cl-check-type name string) - (pcase-let* ((fn-name (intern (concat "org-ql-view-column-format-" (downcase name)))) - ((map :face :max-width) plist) - (max-width-variable (intern (concat "org-ql-view-column-" name "-max-width"))) - (max-width-docstring (format "Maximum width of the %s column." name))) - `(progn - ,(when (plist-member plist :max-width) - `(defcustom ,max-width-variable - ,max-width - ,max-width-docstring - :type '(choice (integer :tag "Maximum width") - (const :tag "Unlimited width" nil)))) - (defun ,fn-name (element depth) - (if-let ((string (progn ,@body))) - (progn - ,(when max-width - `(when ,max-width-variable - (setf string (truncate-string-to-width string ,max-width-variable nil nil "…")))) - ,(when face - ;; Faces are not defined until load time, while this checks type at expansion - ;; time, so we can only test that the argument is a symbol, not a face. - (cl-check-type face symbol ":face must be a face symbol") - `(setf string (propertize string 'face ',face))) - string) - "")) - (setf (map-elt org-ql-view-column-format-fns ,name) #',fn-name)))) - -(org-ql-view-define-column "Keyword" (:max-width nil) - (let ((indentation (make-string (+ (* depth org-ql-view-taxy-level-indent) - org-ql-view-taxy-item-indent) - ? )) - (keyword (or (org-element-property :todo-keyword element) ""))) +(org-ql-view-define-column "Keyword" (:max-width nil :align 'right) + (let ((keyword (or (org-element-property :todo-keyword item) ""))) (unless (string-empty-p keyword) ;; NOTE: We use `substring-no-properties' to avoid propagating ;; `wrap-prefix' and `line-prefix' properties that may be ;; present on the source buffer's keyword. (setf keyword (org-ql-view--add-todo-face (substring-no-properties keyword)))) - (concat indentation keyword))) + keyword)) (org-ql-view-define-column "Heading" (:max-width 60) - (ignore depth) (org-link-display-format (org-element-property - :raw-value (org-ql-view--add-faces element)))) - -(org-ql-view-define-column "Planning" (:max-width nil) - (ignore depth) - (when-let ((planning-element (or (org-element-property :deadline element) - (org-element-property :scheduled element) - (org-element-property :closed element)))) - (org-ql-view--format-relative-date - (floor (/ (ts-diff (ts-now) (ts-parse-org-element planning-element)) - 86400))))) + :raw-value (org-ql-view--add-faces item)))) (org-ql-view-define-column "Pri" (:max-width nil) - (ignore depth) - (or (-some->> (org-element-property :priority element) + (or (-some->> (org-element-property :priority item) (char-to-string) (format "[#%s]") (org-ql-view--add-priority-face)) "")) +(org-ql-view-define-column "Planning" (:max-width nil) + (when-let ((planning-element (or (org-element-property :deadline item) + (org-element-property :scheduled item) + (org-element-property :closed item)))) + (org-ql-view--format-relative-date + (floor (/ (ts-diff (ts-now) (ts-parse-org-element planning-element)) + 86400))))) + (org-ql-view-define-column "Tags" (:max-width nil) - (ignore depth) ;; Copied from `org-ql-view--format-element'. (when-let ((tags (if org-use-tag-inheritance - ;; MAYBE: Use our own variable instead of `org-use-tag-inheritance'. - (if-let ((marker (or (org-element-property :org-hd-marker element) - (org-element-property :org-marker element)))) - (with-current-buffer (marker-buffer marker) - (org-with-wide-buffer - (goto-char marker) - (cl-loop for type in (org-ql--tags-at marker) - unless (or (eq 'org-ql-nil type) + ;; MAYBE: Use our own variable instead of `org-use-tag-inheritance'. + (if-let ((marker (or (org-element-property :org-hd-marker item) + (org-element-property :org-marker item)))) + (with-current-buffer (marker-buffer marker) + (org-with-wide-buffer + (goto-char marker) + (cl-loop for type in (org-ql--tags-at marker) + unless (or (eq 'org-ql-nil type) (not type)) - append type))) + append type))) ;; No marker found ;; TODO: Use `display-warning' with `org-ql' as the type. - (warn "No marker found for item: %s" element) - (org-element-property :tags element)) - (org-element-property :tags element)))) + (warn "No marker found for item: %s" item) + (org-element-property :tags item)) + (org-element-property :tags item)))) (org-add-props (concat ":" (string-join tags ":") ":") - nil 'face 'org-tag))) + nil 'face 'org-tag))) -;;;; Defining taxy keys with macro +(unless org-ql-view-columns + (setq-default org-ql-view-columns + (get 'org-ql-view-columns 'standard-value))) -(defvar taxy-org-ql-view-keys nil) +;;;; Taxy keys -(defmacro taxy-org-ql-view-define-key (name args &rest body) +(taxy-define-key-definer taxy-org-ql-view-define-key + taxy-org-ql-view-keys "taxy-org-ql--key" "Define a `taxy-org-ql-view' key function by NAME having BODY taking ARGS. -Within BODY, `element' is bound to the `org-element' element +Within BODY, `item' is bound to the `org-element' element being tested. Defines a function named `taxy-org-ql--predicate-NAME', and adds an entry to `taxy-org-ql-view-keys' mapping NAME to the new -function symbol." - (declare (indent defun) - (debug (&define symbolp listp &rest def-form))) - (let* ((fn-symbol (intern (format "taxy-org-ql--predicate-%s" name))) - (fn `(lambda (element ,@args) - ,@body))) - `(progn - (fset ',fn-symbol ,fn) - (setf (map-elt taxy-org-ql-view-keys ',name) ',fn-symbol)))) +function symbol.") (taxy-org-ql-view-define-key heading (&rest strings) - "Return STRINGS that ELEMENT's heading matches." - (when-let ((matches (cl-loop with heading = (org-element-property :raw-value element) - for string in strings - when (string-match (regexp-quote string) heading) - collect string))) + "Return STRINGS that ITEM's heading matches." + (when-let ((matches (cl-loop with heading = (org-element-property :raw-value item) + for string in strings + when (string-match (regexp-quote string) heading) + collect string))) (format "Heading: %s" (string-join matches ", ")))) (taxy-org-ql-view-define-key todo (&optional keyword) - "Return the to-do keyword for ELEMENT. + "Return the to-do keyword for ITEM. If KEYWORD, return whether it matches that." - (when-let ((element-keyword (org-element-property :todo-keyword element))) + (when-let ((element-keyword (org-element-property :todo-keyword item))) (cl-flet ((format-keyword - (keyword) (format "To-do: %s" keyword))) + (keyword) (format "To-do: %s" keyword))) (pcase keyword - ('nil (format-keyword element-keyword)) - (_ (pcase element-keyword - ((pred (equal keyword)) - (format-keyword element-keyword)))))))) + ('nil (format-keyword element-keyword)) + (_ (pcase element-keyword + ((pred (equal keyword)) + (format-keyword element-keyword)))))))) (taxy-org-ql-view-define-key tags (&rest tags) - "Return the tags for ELEMENT. + "Return the tags for ITEM. If TAGS, return whether it matches them." (cl-flet ((tags-at - (pos) (apply #'append (delq 'org-ql-nil (org-ql--tags-at pos))))) - (org-with-point-at (org-element-property :org-hd-marker element) + (pos) (apply #'append (delq 'org-ql-nil (org-ql--tags-at pos))))) + (org-with-point-at (org-element-property :org-hd-marker item) (pcase tags - ('nil (tags-at (point))) - (_ (when-let (common-tags (seq-intersection tags (tags-at (point)) - #'cl-equalp)) - (format "Tags: %s" (string-join common-tags ", ")))))))) + ('nil (tags-at (point))) + (_ (when-let (common-tags (seq-intersection tags (tags-at (point)) + #'cl-equalp)) + (format "Tags: %s" (string-join common-tags ", ")))))))) (taxy-org-ql-view-define-key priority (&optional priority) - "Return ELEMENT's priority as a string. -If PRIORITY, return it if it matches ELEMENT's priority." - (when-let ((priority-number (org-element-property :priority element))) + "Return ITEM's priority as a string. +If PRIORITY, return it if it matches ITEM's priority." + (when-let ((priority-number (org-element-property :priority item))) (cl-flet ((format-priority - (num) (format "Priority: %s" num))) + (num) (format "Priority: %s" num))) ;; FIXME: Priority numbers may be wildly larger, right? (pcase priority - ('nil (format-priority (char-to-string priority-number))) - (_ (pcase (char-to-string priority-number) - ((and (pred (equal priority)) string) - (format-priority string)))))))) + ('nil (format-priority (char-to-string priority-number))) + (_ (pcase (char-to-string priority-number) + ((and (pred (equal priority)) string) + (format-priority string)))))))) (taxy-org-ql-view-define-key planning-month () - "Return ELEMENT's planning-date month, or nil. + "Return ITEM's planning-date month, or nil. Returns in format \"%Y-%m (%B)\"." - (when-let ((planning-element (or (org-element-property :deadline element) - (org-element-property :scheduled element) - (org-element-property :closed element)))) + (when-let ((planning-element (or (org-element-property :deadline item) + (org-element-property :scheduled item) + (org-element-property :closed item)))) (ts-format "Planning: %Y-%m (%B)" (ts-parse-org-element planning-element)))) (taxy-org-ql-view-define-key planning-year () - "Return ELEMENT's planning-date year, or nil. + "Return ITEM's planning-date year, or nil. Returns in format \"%Y\"." - (when-let ((planning-element (or (org-element-property :deadline element) - (org-element-property :scheduled element) - (org-element-property :closed element)))) + (when-let ((planning-element (or (org-element-property :deadline item) + (org-element-property :scheduled item) + (org-element-property :closed item)))) (ts-format "Planning: %Y" (ts-parse-org-element planning-element)))) (taxy-org-ql-view-define-key planning-date () - "Return ELEMENT's planning date, or nil. + "Return ITEM's planning date, or nil. Returns in format \"%Y-%m-%d\"." - (when-let ((planning-element (or (org-element-property :deadline element) - (org-element-property :scheduled element) - (org-element-property :closed element)))) + (when-let ((planning-element (or (org-element-property :deadline item) + (org-element-property :scheduled item) + (org-element-property :closed item)))) (ts-format "Planning: %Y-%m-%d" (ts-parse-org-element planning-element)))) (taxy-org-ql-view-define-key planning () - "Return \"Planned\" if ELEMENT has a planning date." - (when (or (org-element-property :deadline element) - (org-element-property :scheduled element) - (org-element-property :closed element)) + "Return \"Planned\" if ITEM has a planning date." + (when (or (org-element-property :deadline item) + (org-element-property :scheduled item) + (org-element-property :closed item)) "Planned")) (taxy-org-ql-view-define-key category () - "Return ELEMENT's category." - (org-with-point-at (org-element-property :org-hd-marker element) - (org-get-category))) + "Return ITEM's category." + (org-with-point-at (org-element-property :org-hd-marker item) + (concat "Category: " (org-get-category)))) (defun taxy-org-ql--latest-timestamp-in (regexp element) "Return the latest timestamp matching REGEXP in ELEMENT. @@ -290,100 +218,55 @@ Searches in ELEMENT's buffer." (car (sort tss #'ts>)))))) (taxy-org-ql-view-define-key ts-year () - "Return the year of ELEMENT's latest timestamp." - (when-let ((latest-ts (taxy-org-ql--latest-timestamp-in org-element--timestamp-regexp element))) + "Return the year of ITEM's latest timestamp." + (when-let ((latest-ts (taxy-org-ql--latest-timestamp-in org-element--timestamp-regexp item))) (ts-format "%Y" latest-ts))) (taxy-org-ql-view-define-key ts-month () - "Return the month of ELEMENT's latest timestamp." - (when-let ((latest-ts (taxy-org-ql--latest-timestamp-in org-element--timestamp-regexp element))) + "Return the month of ITEM's latest timestamp." + (when-let ((latest-ts (taxy-org-ql--latest-timestamp-in org-element--timestamp-regexp item))) (ts-format "%Y-%m (%B)" latest-ts))) (taxy-org-ql-view-define-key deadline (&rest args) - "Return whether ELEMENT has a deadline according to ARGS." - (when-let ((deadline-element (org-element-property :deadline element))) + "Return whether ITEM has a deadline according to ARGS." + (when-let ((deadline-element (org-element-property :deadline item))) (pcase args (`(,(or 'nil 't)) "Deadlined") (_ (let ((element-ts (ts-parse-org-element deadline-element))) - (pcase args - ((and `(:past) - (guard (ts> (ts-now) element-ts))) - "Overdue") - ((and `(:today) - (guard (equal (ts-day (ts-now)) (ts-day element-ts)))) - "Due today") - ((and `(:future) - (guard (ts< (ts-now) element-ts))) - ;; FIXME: Not necessarily soon. - "Due soon") - ((and `(:before ,target-date) - (guard (ts< element-ts (ts-parse target-date)))) - (concat "Due before: " target-date)) - ((and `(:after ,target-date) - (guard (ts> element-ts (ts-parse target-date)))) - (concat "Due after: " target-date)) - ((and `(:on ,target-date) - (guard (let ((now (ts-now))) - (and (equal (ts-doy element-ts) - (ts-doy now)) - (equal (ts-year element-ts) - (ts-year now)))))) - (concat "Due on: " target-date)) - ((and `(:from ,target-ts) - (guard (ts<= (ts-parse target-ts) element-ts))) - (concat "Due from: " target-ts)) - ((and `(:to ,target-ts) - (guard (ts>= (ts-parse target-ts) element-ts))) - (concat "Due to: " target-ts)) - ((and `(:from ,from-ts :to ,to-ts) - (guard (and (ts<= (ts-parse from-ts) element-ts) - (ts>= (ts-parse to-ts) element-ts)))) - (format "Due from: %s to %s" from-ts to-ts)))))))) - -(defun taxy-org-ql-view-take-fn (keys) - "Return a `taxy' \"take\" function for KEYS. -Each of KEYS should be a function alias defined in -`taxy-org-ql-view-keys', or a list of such KEY-FNS (recursively, -ad infinitum, approximately)." - (let ((macrolets (cl-loop for (name . fn) in taxy-org-ql-view-keys - collect `(,name ',fn)))) - (cl-labels ((expand-form - ;; Is using (cadr (macroexpand-all ...)) really better than `eval'? - (form) (cadr - (macroexpand-all - `(cl-symbol-macrolet (,@macrolets) - ,form)))) - (quote-fn - (fn) (pcase fn - ((pred symbolp) fn) - (`(,(and (pred symbolp) fn) - . ,(and args (guard (cl-typecase (car args) - ((or keyword (and atom (not symbol))) - t))))) - ;; Key with args: replace with a lambda that - ;; calls that key's function with given args. - `(lambda (element) - (,(expand-form fn) element ,@args))) - ((pred listp) (cons 'list (mapcar #'quote-fn fn)))))) - (setf keys (mapcar #'quote-fn keys)) - (expand-form - `(lambda (item taxy) - (taxy-take-keyed (list ,@keys) item taxy)))))) - -(defun taxy-org-ql-view-make-taxy (name keys &rest args) - "Return a dynamic `taxy-org-ql-view-section' taxy named NAME having KEYS. -KEYS is passed to `taxy-org-ql-view-take-fn', which see." - (declare (indent defun)) - (apply #'make-taxy-org-ql-view-section - :name name - :take (taxy-org-ql-view-take-fn keys) - args)) - -;;;; Variables - -;;;; Customization - -;;;; Commands + (pcase args + ((and `(:past) + (guard (ts> (ts-now) element-ts))) + "Overdue") + ((and `(:today) + (guard (equal (ts-day (ts-now)) (ts-day element-ts)))) + "Due today") + ((and `(:future) + (guard (ts< (ts-now) element-ts))) + ;; FIXME: Not necessarily soon. + "Due soon") + ((and `(:before ,target-date) + (guard (ts< element-ts (ts-parse target-date)))) + (concat "Due before: " target-date)) + ((and `(:after ,target-date) + (guard (ts> element-ts (ts-parse target-date)))) + (concat "Due after: " target-date)) + ((and `(:on ,target-date) + (guard (let ((now (ts-now))) + (and (equal (ts-doy element-ts) + (ts-doy now)) + (equal (ts-year element-ts) + (ts-year now)))))) + (concat "Due on: " target-date)) + ((and `(:from ,target-ts) + (guard (ts<= (ts-parse target-ts) element-ts))) + (concat "Due from: " target-ts)) + ((and `(:to ,target-ts) + (guard (ts>= (ts-parse target-ts) element-ts))) + (concat "Due to: " target-ts)) + ((and `(:from ,from-ts :to ,to-ts) + (guard (and (ts<= (ts-parse from-ts) element-ts) + (ts>= (ts-parse to-ts) element-ts)))) + (format "Due from: %s to %s" from-ts to-ts)))))))) ;;;; Functions @@ -391,11 +274,15 @@ KEYS is passed to `taxy-org-ql-view-take-fn', which see." (buffers-or-files query &key taxy-keys sort) "Show Org QL QUERY on BUFFERS-OR-FILES with `taxy-org-ql-view'." (declare (indent 1)) - (let* ((title (format "Query:%S In:%S" query buffers-or-files)) - (buffer-name (format "*Taxy Org QL View: %s*" title))) + (let* ((title (format "Query:%S In:%S" + (org-ql--query-sexp-to-string query) + buffers-or-files)) + (buffer-name (format "*Taxy Org QL View: %s*" title))) (when (get-buffer buffer-name) ;; Reusing an existing magit-section buffer seems to cause a lot - ;; of GC, so just kill it if it already exists. + ;; of GC, so just kill it if it already exists. However, this + ;; makes window management more difficult, so it'd be preferable + ;; to avoid this. (kill-buffer buffer-name)) (with-current-buffer (get-buffer-create buffer-name) (magit-section-mode) @@ -410,40 +297,36 @@ KEYS is passed to `taxy-org-ql-view-take-fn', which see." (declare (indent 1)) (let (format-table column-sizes) (cl-labels ((format-item (item) (gethash item format-table)) - (make-fn (&rest args) - (apply #'make-taxy-org-ql-view-section + (make-fn (&rest args) + (apply #'make-taxy-magit-section :make #'make-fn + :take (taxy-make-take-function taxy-keys taxy-org-ql-view-keys) :format-fn #'format-item ;; :heading-face-fn #'heading-face - :heading-indent org-ql-view-taxy-level-indent - :item-indent 0 + :heading-indent org-ql-view-level-indent + :item-indent org-ql-view-item-indent args))) (let* ((title (format "Query:%S In:%S" - (org-ql--query-sexp-to-string query) buffers-or-files)) - (items (org-ql-select buffers-or-files query - :action 'element-with-markers - :sort sort)) - (taxy (thread-last (make-fn - :name title - :take (taxy-org-ql-view-take-fn taxy-keys)) - (taxy-fill items))) - (taxy-magit-section-insert-indent-items nil) - format-cons header) - ;; FIXME: Adding a search overwrites the `header-line-format'. - (setf format-cons (taxy-magit-section-format-items - org-ql-view-columns org-ql-view-column-format-fns taxy) - format-table (car format-cons) - column-sizes (cdr format-cons) - ;; NOTE: The first column is handled differently. - header (concat (format (format " %%-%ss" (cdar column-sizes)) (caar column-sizes)) - (cl-loop for (name . size) in (cdr column-sizes) - for spec = (format " %%-%ss" size) - concat (format spec name))) - header-line-format header) - (let ((inhibit-read-only t)) - (save-excursion - (goto-char (point-max)) - (taxy-magit-section-insert taxy :items 'first))))))) + (org-ql--query-sexp-to-string query) buffers-or-files)) + (items (org-ql-select buffers-or-files query + :action 'element-with-markers + :sort sort)) + (taxy (thread-last (make-fn + :name title) + (taxy-fill items))) + (taxy-magit-section-insert-indent-items nil) + format-cons) + ;; FIXME: Adding a search overwrites the `header-line-format'. + (setf format-cons (taxy-magit-section-format-items + org-ql-view-columns org-ql-view-column-formatters taxy) + format-table (car format-cons) + column-sizes (cdr format-cons) + header-line-format (taxy-magit-section-format-header column-sizes org-ql-view-column-formatters)) + (let ((inhibit-read-only t)) + (save-excursion + (goto-char (point-max)) + (taxy-magit-section-insert taxy :items 'first + :initial-depth -1))))))) ;;;; Footer From f0548049685eb9e1210c63ddf3b50865c20601dd Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Wed, 22 Sep 2021 00:35:46 -0500 Subject: [PATCH 05/29] WIP: Tidy --- taxy-org-ql-view.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 8e9ed40..c000b8a 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -321,7 +321,8 @@ Searches in ELEMENT's buffer." org-ql-view-columns org-ql-view-column-formatters taxy) format-table (car format-cons) column-sizes (cdr format-cons) - header-line-format (taxy-magit-section-format-header column-sizes org-ql-view-column-formatters)) + header-line-format (taxy-magit-section-format-header + column-sizes org-ql-view-column-formatters)) (let ((inhibit-read-only t)) (save-excursion (goto-char (point-max)) From 998bd1edda2c8d785eb3499046cf0ba73a003364 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Fri, 18 Mar 2022 11:12:42 -0500 Subject: [PATCH 06/29] WIP: Update argument --- taxy-org-ql-view.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index c000b8a..9f71574 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -303,7 +303,7 @@ Searches in ELEMENT's buffer." :take (taxy-make-take-function taxy-keys taxy-org-ql-view-keys) :format-fn #'format-item ;; :heading-face-fn #'heading-face - :heading-indent org-ql-view-level-indent + :level-indent org-ql-view-level-indent :item-indent org-ql-view-item-indent args))) (let* ((title (format "Query:%S In:%S" From e28f80daf806621d01d638106f51187f3169f47c Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Fri, 18 Mar 2022 11:32:21 -0500 Subject: [PATCH 07/29] WIP: Add marker to items for Agenda commands --- taxy-org-ql-view.el | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 9f71574..2b47470 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -67,9 +67,10 @@ second levels." keyword)) (org-ql-view-define-column "Heading" (:max-width 60) - (org-link-display-format - (org-element-property - :raw-value (org-ql-view--add-faces item)))) + (propertize (org-link-display-format + (org-element-property + :raw-value (org-ql-view--add-faces item))) + :org-hd-marker (org-element-property :org-hd-marker item))) (org-ql-view-define-column "Pri" (:max-width nil) (or (-some->> (org-element-property :priority item) @@ -296,7 +297,21 @@ Searches in ELEMENT's buffer." "Show Org QL QUERY on BUFFERS-OR-FILES with `taxy-org-ql-view'." (declare (indent 1)) (let (format-table column-sizes) - (cl-labels ((format-item (item) (gethash item format-table)) + (cl-labels ((format-item (item) + ;; For compatibility with Org Agenda, we + ;; add the marker property to the whole + ;; string (though it only seems to check + ;; at BOL). + (let* ((string (gethash item format-table)) + (marker (or (get-text-property 0 :org-hd-marker string) + (when-let ((pos (next-single-property-change 0 :org-hd-marker string))) + (get-text-property pos :org-hd-marker string))))) + ;; I don't understand why Org sometimes + ;; uses one property and sometimes the + ;; other. + (propertize string + 'org-hd-marker marker + 'org-marker marker))) (make-fn (&rest args) (apply #'make-taxy-magit-section :make #'make-fn From 023f2e9521295eab0038c39cdb8c4c5f75aaeb1f Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Fri, 18 Mar 2022 12:29:09 -0500 Subject: [PATCH 08/29] WIP: Define org-ql-view-mode and map --- taxy-org-ql-view.el | 27 +++++++++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 2b47470..c35ea23 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -269,6 +269,30 @@ Searches in ELEMENT's buffer." (ts>= (ts-parse to-ts) element-ts)))) (format "Due from: %s to %s" from-ts to-ts)))))))) +;;;; Mode + +(defvar org-ql-view-mode-map + (let* ((org-agenda-mode-map-copy (copy-keymap org-agenda-mode-map)) + map) + (cl-loop for key in (where-is-internal #'org-agenda-goto org-agenda-mode-map-copy) + do (define-key org-agenda-mode-map-copy key nil)) + (setf map (make-composed-keymap magit-section-mode-map org-agenda-mode-map-copy)) + (define-key map "g" #'org-ql-view-refresh) + (define-key map "r" #'org-ql-view-refresh) + (define-key map "q" #'bury-buffer) + (define-key map "v" #'org-ql-view-dispatch) + (define-key map (kbd "C-x C-s") #'org-ql-view-save) + ;; HACK: Undefine Org's extra "" binding from + ;; org-agenda-mode-map, which interferes with the "TAB" binding + ;; from magit-section-mode-map. (This shouldn't be necessary + ;; since we're already looping through the bindings earlier, but + ;; for some reason, it is.) + (define-key map (kbd "") nil) + map)) + +(define-derived-mode org-ql-view-mode magit-section-mode "Org QL View" + "TODO: Docstring.") + ;;;; Functions (cl-defun taxy-org-ql-search @@ -286,8 +310,7 @@ Searches in ELEMENT's buffer." ;; to avoid this. (kill-buffer buffer-name)) (with-current-buffer (get-buffer-create buffer-name) - (magit-section-mode) - (use-local-map (make-composed-keymap (list magit-section-mode-map org-ql-view-map))) + (org-ql-view-mode) (taxy-org-ql-view--add-search buffers-or-files query :sort sort :taxy-keys taxy-keys) (pop-to-buffer (current-buffer))))) From 0f8ae0e85033a3838acb8b2dfde4c39bd3389b0d Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Fri, 18 Mar 2022 12:41:03 -0500 Subject: [PATCH 09/29] WIP: Fix query in section heading --- taxy-org-ql-view.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index c35ea23..37971f3 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -345,7 +345,9 @@ Searches in ELEMENT's buffer." :item-indent org-ql-view-item-indent args))) (let* ((title (format "Query:%S In:%S" - (org-ql--query-sexp-to-string query) buffers-or-files)) + (or (org-ql--query-sexp-to-string query) + (prin1-to-string query)) + buffers-or-files)) (items (org-ql-select buffers-or-files query :action 'element-with-markers :sort sort)) From fc7447185a1a95af8bcbe4858a024f3916bf3bfe Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Fri, 18 Mar 2022 12:41:19 -0500 Subject: [PATCH 10/29] WIP: Larger high-level headings --- taxy-org-ql-view.el | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 37971f3..50d941f 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -335,12 +335,20 @@ Searches in ELEMENT's buffer." (propertize string 'org-hd-marker marker 'org-marker marker))) + (heading-face (depth) + ;; TODO: Make customizeable. + (let ((height (pcase depth + ((pred (> 0)) 1.3) + (0 1.2) + (1 1.1) + (_ 1.0)))) + (list :inherit 'magit-section-heading :height height))) (make-fn (&rest args) (apply #'make-taxy-magit-section :make #'make-fn :take (taxy-make-take-function taxy-keys taxy-org-ql-view-keys) :format-fn #'format-item - ;; :heading-face-fn #'heading-face + :heading-face-fn #'heading-face :level-indent org-ql-view-level-indent :item-indent org-ql-view-item-indent args))) From fd9af0aae6a17c174ab7ba7a377b6751aee57f89 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Fri, 18 Mar 2022 13:00:06 -0500 Subject: [PATCH 11/29] WIP: Set org-agenda-type in org-ql-view-mode --- taxy-org-ql-view.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 50d941f..a5bbcae 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -291,7 +291,9 @@ Searches in ELEMENT's buffer." map)) (define-derived-mode org-ql-view-mode magit-section-mode "Org QL View" - "TODO: Docstring.") + "TODO: Docstring." + ;; For compatibility with Org Agenda commands. + (setq-local org-agenda-type 'search)) ;;;; Functions From 58ae8838564d26143450549f7787c1540e068a04 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sun, 20 Mar 2022 18:48:43 -0500 Subject: [PATCH 12/29] Change: Use --header-line-format for query headings --- taxy-org-ql-view.el | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index a5bbcae..efc871c 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -354,10 +354,11 @@ Searches in ELEMENT's buffer." :level-indent org-ql-view-level-indent :item-indent org-ql-view-item-indent args))) - (let* ((title (format "Query:%S In:%S" - (or (org-ql--query-sexp-to-string query) - (prin1-to-string query)) - buffers-or-files)) + (let* ((title (org-ql-view--header-line-format + :buffers-files buffers-or-files + :query query + ;; FIXME: View titles. + )) (items (org-ql-select buffers-or-files query :action 'element-with-markers :sort sort)) From d11edbc1323c012da4795b653ee245ea281c8214 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sun, 20 Mar 2022 18:50:12 -0500 Subject: [PATCH 13/29] Add: Faces --- taxy-org-ql-view.el | 50 +++++++++++++++++++++++++++++++++++++-------- 1 file changed, 42 insertions(+), 8 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index efc871c..2862c30 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -53,6 +53,37 @@ example, setting to -1 prevents indentation of the first and second levels." :type 'integer) +;;;;; Faces + +(defgroup org-ql-view-faces nil + "Faces for Org QL View buffers." + :group 'org-ql-view-taxy) + +(defface org-ql-view-header-line + '((t (:inherit header-line :weight bold))) + "Header line.") + +(defface org-ql-view-query-heading + '((t (:inherit header-line :height 1.3))) + "Query headings.") + +(defface org-ql-view-heading + `((t (:inherit magit-section-heading :weight bold))) + "Group headings. +Inherited by level-specific faces.") + +(defface org-ql-view-heading-1 + `((t (:inherit org-ql-view-heading + :height 1.2 :overline t + :background ,(face-background 'header-line)))) + "Level-1 group headings.") + +(defface org-ql-view-heading-2 + `((t (:inherit org-ql-view-heading + :height 1.1 :overline t + :background ,(face-background 'header-line)))) + "Level-2 group headings.") + ;;;;; Columns (taxy-magit-section-define-column-definer "org-ql-view") @@ -337,14 +368,15 @@ Searches in ELEMENT's buffer." (propertize string 'org-hd-marker marker 'org-marker marker))) - (heading-face (depth) - ;; TODO: Make customizeable. - (let ((height (pcase depth - ((pred (> 0)) 1.3) - (0 1.2) - (1 1.1) - (_ 1.0)))) - (list :inherit 'magit-section-heading :height height))) + (heading-face + (depth) (pcase depth + (-1 'org-ql-view-query-heading) + ;; NOTE: Faces count from 1 (like + ;; `outline-` faces), but depth from 0 (or + ;; -1 for query headings). + (0 'org-ql-view-heading-1) + (1 'org-ql-view-heading-2) + (_ 'org-ql-view-heading))) (make-fn (&rest args) (apply #'make-taxy-magit-section :make #'make-fn @@ -374,6 +406,8 @@ Searches in ELEMENT's buffer." column-sizes (cdr format-cons) header-line-format (taxy-magit-section-format-header column-sizes org-ql-view-column-formatters)) + (add-face-text-property 0 (length header-line-format) 'org-ql-view-header-line + nil header-line-format) (let ((inhibit-read-only t)) (save-excursion (goto-char (point-max)) From 32ff0d34323a750778a9e7ed3c4a5893705d71bd Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sun, 20 Mar 2022 19:30:38 -0500 Subject: [PATCH 14/29] Add: Category column --- taxy-org-ql-view.el | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 2862c30..5fe03be 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -88,6 +88,11 @@ Inherited by level-specific faces.") (taxy-magit-section-define-column-definer "org-ql-view") +(org-ql-view-define-column "Category" (:max-width nil :align 'right) + (or (org-with-point-at (org-element-property :org-hd-marker item) + (org-get-category (point))) + "")) + (org-ql-view-define-column "Keyword" (:max-width nil :align 'right) (let ((keyword (or (org-element-property :todo-keyword item) ""))) (unless (string-empty-p keyword) From a20bba775aa0a50cead49e9c1cfebc65f6bcae09 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Mon, 18 Jul 2022 07:19:22 -0500 Subject: [PATCH 15/29] WIP: Fix byte compilation warnings --- taxy-org-ql-view.el | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 5fe03be..9f6b1a4 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -26,6 +26,7 @@ ;;;; Requirements +(require 'cl-lib) (require 'map) (require 'seq) @@ -86,7 +87,8 @@ Inherited by level-specific faces.") ;;;;; Columns -(taxy-magit-section-define-column-definer "org-ql-view") +(eval-and-compile + (taxy-magit-section-define-column-definer "org-ql-view")) (org-ql-view-define-column "Category" (:max-width nil :align 'right) (or (org-with-point-at (org-element-property :org-hd-marker item) @@ -150,15 +152,16 @@ Inherited by level-specific faces.") ;;;; Taxy keys -(taxy-define-key-definer taxy-org-ql-view-define-key - taxy-org-ql-view-keys "taxy-org-ql--key" - "Define a `taxy-org-ql-view' key function by NAME having BODY taking ARGS. -Within BODY, `item' is bound to the `org-element' element -being tested. +(eval-and-compile + (taxy-define-key-definer taxy-org-ql-view-define-key + taxy-org-ql-view-keys "taxy-org-ql--key" + "Define a `taxy-org-ql-view' key function by NAME having BODY taking ARGS. +Within BODY, `item' is bound to the `org-element' element being +tested. Defines a function named `taxy-org-ql--predicate-NAME', and adds an entry to `taxy-org-ql-view-keys' mapping NAME to the new -function symbol.") +function symbol.")) (taxy-org-ql-view-define-key heading (&rest strings) "Return STRINGS that ITEM's heading matches." From bbe09d754aff31df157cb639b8618947c95e0e54 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Mon, 18 Jul 2022 07:19:36 -0500 Subject: [PATCH 16/29] WIP: Adjust heading faces --- taxy-org-ql-view.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 9f6b1a4..f19600d 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -75,13 +75,13 @@ Inherited by level-specific faces.") (defface org-ql-view-heading-1 `((t (:inherit org-ql-view-heading - :height 1.2 :overline t + :height 1.1 :overline t :background ,(face-background 'header-line)))) "Level-1 group headings.") (defface org-ql-view-heading-2 `((t (:inherit org-ql-view-heading - :height 1.1 :overline t + :height 1.0 :overline nil :background ,(face-background 'header-line)))) "Level-2 group headings.") From 97b21cd52c229f2bd7579ff945fc6a24b3c35804 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Mon, 18 Jul 2022 07:20:43 -0500 Subject: [PATCH 17/29] WIP: Add (agenda) key --- taxy-org-ql-view.el | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index f19600d..bcdcc0e 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -239,6 +239,23 @@ Returns in format \"%Y-%m-%d\"." (org-element-property :closed item)) "Planned")) +(taxy-org-ql-view-define-key agenda + (&optional (days (pcase org-agenda-span + ('week 7) + ('day 1) + ('month (date-days-in-month (ts-year (ts-now)) (ts-month (ts-now)))) + ('year 365) + ((pred numberp) org-agenda-span)))) + ;; FIXME: This isn't quite how Org Agenda works. + "Return ITEM's planning date if it's within DAYS of the current date." + (when-let ((planning-element (or (org-element-property :deadline item) + (org-element-property :scheduled item) + (org-element-property :closed item)))) + (let ((parsed-ts (ts-parse-org-element planning-element))) + (when (<= (ts-diff (ts-apply 'hour 0 'minute 0 'second 0 (ts-now)) parsed-ts) + (* days 86400)) + (ts-format "Agenda: %Y-%m-%d" parsed-ts))))) + (taxy-org-ql-view-define-key category () "Return ITEM's category." (org-with-point-at (org-element-property :org-hd-marker item) From 37b1a063ab93c524c48beffc87a3a7fd5cb50b67 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sun, 19 Feb 2023 12:00:15 -0600 Subject: [PATCH 18/29] WIP: Multiple queries per view, (planned), etc. Very useful now. Still a lot of potential UI work to make it easier to use, and plugging it into links and bookmarks, etc. --- taxy-org-ql-view.el | 178 ++++++++++++++++++++++++++++++++++++-------- 1 file changed, 146 insertions(+), 32 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index bcdcc0e..ab1f22f 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -37,6 +37,16 @@ ;;;; Structs +;;;; Variables + +(defvar-local taxy-org-ql-view-args nil + "Arguments passed to `taxy-org-ql-search'. +Used when updating the view.") + +(defvar-local taxy-org-ql-view-queries nil + "Queries shown in the current buffer. +Used when updating the view.") + ;;;; Customization (defgroup org-ql-view-taxy nil @@ -68,6 +78,10 @@ second levels." '((t (:inherit header-line :height 1.3))) "Query headings.") +(defface taxy-org-ql-view-header + '((t (:inherit header-line :height 1.5 :weight bold :overline t :extend t))) + "View top-level section names.") + (defface org-ql-view-heading `((t (:inherit magit-section-heading :weight bold))) "Group headings. @@ -325,16 +339,75 @@ Searches in ELEMENT's buffer." (ts>= (ts-parse to-ts) element-ts)))) (format "Due from: %s to %s" from-ts to-ts)))))))) +(taxy-org-ql-view-define-key planned (&rest args) + "Return whether ITEM is planned according to ARGS. +DEADLINE, SCHEDULED, and CLOSED timestamps are considered, in +that order." + (when-let ((planned-element (or (org-element-property :deadline item) + (org-element-property :scheduled item) + (org-element-property :closed item)))) + ;; TODO: Every key should support a :name like this. + (let ((name (cadr (member :name args)))) + (when name + (let ((pos (cl-position :name args))) + (setf args (append (cl-subseq args 0 pos) + (cl-subseq args (+ 2 pos)))))) + (pcase args + (`(,(or 'nil 't)) (or name "Planned")) + (_ (let ((element-ts (ts-parse-org-element planned-element))) + (pcase args + ((and `(:past) + (guard (ts> (ts-now) element-ts))) + (or name "Planned: past")) + ((and `(:today) + (guard (equal (ts-day (ts-now)) (ts-day element-ts)))) + (or name "Planned: today")) + ((and `(:future) + (guard (ts< (ts-now) element-ts))) + ;; FIXME: Not necessarily soon. + (or name "Planned: future")) + ((and `(:before ,target-date) + (guard (ts< element-ts (ts-parse target-date)))) + (or name (concat "Planned before: " target-date))) + ((and `(:after ,target-date) + (guard (ts> element-ts (ts-parse target-date)))) + (or name (concat "Planned after: " target-date))) + ((and `(:on ,target-date) + (guard (let ((now (ts-now))) + (and (equal (ts-doy element-ts) + (ts-doy now)) + (equal (ts-year element-ts) + (ts-year now)))))) + (or name (concat "Planned on: " target-date))) + ((and `(:from ,target-ts) + (guard (ts<= (ts-parse target-ts) element-ts))) + (or name (concat "Planned from: " target-ts))) + ((and `(:to ,target-ts) + (guard (ts>= (ts-parse target-ts) element-ts))) + (or name (concat "Planned to: " target-ts))) + ((and `(:from ,from-ts :to ,to-ts) + (guard (and (ts<= (ts-parse from-ts) element-ts) + (ts>= (ts-parse to-ts) element-ts)))) + (or name (format "Planned from: %s to %s" from-ts to-ts)))))))))) + +(taxy-org-ql-view-define-key file (&key full-path) + "Return the name of ITEM's containing file." + (let ((filename (org-with-point-at (org-element-property :org-hd-marker item) + (if full-path + (buffer-file-name) + (file-name-nondirectory (buffer-file-name)))))) + (concat "File: " filename))) + ;;;; Mode -(defvar org-ql-view-mode-map +(defvar taxy-org-ql-view-mode-map (let* ((org-agenda-mode-map-copy (copy-keymap org-agenda-mode-map)) map) (cl-loop for key in (where-is-internal #'org-agenda-goto org-agenda-mode-map-copy) do (define-key org-agenda-mode-map-copy key nil)) (setf map (make-composed-keymap magit-section-mode-map org-agenda-mode-map-copy)) - (define-key map "g" #'org-ql-view-refresh) - (define-key map "r" #'org-ql-view-refresh) + (define-key map "g" #'taxy-org-ql-view-refresh) + (define-key map "r" #'taxy-org-ql-view-refresh) (define-key map "q" #'bury-buffer) (define-key map "v" #'org-ql-view-dispatch) (define-key map (kbd "C-x C-s") #'org-ql-view-save) @@ -346,35 +419,75 @@ Searches in ELEMENT's buffer." (define-key map (kbd "") nil) map)) -(define-derived-mode org-ql-view-mode magit-section-mode "Org QL View" +(define-derived-mode taxy-org-ql-view-mode magit-section-mode "Org QL View" "TODO: Docstring." ;; For compatibility with Org Agenda commands. (setq-local org-agenda-type 'search)) ;;;; Functions -(cl-defun taxy-org-ql-search - (buffers-or-files query &key taxy-keys sort) - "Show Org QL QUERY on BUFFERS-OR-FILES with `taxy-org-ql-view'." - (declare (indent 1)) - (let* ((title (format "Query:%S In:%S" - (org-ql--query-sexp-to-string query) - buffers-or-files)) - (buffer-name (format "*Taxy Org QL View: %s*" title))) - (when (get-buffer buffer-name) - ;; Reusing an existing magit-section buffer seems to cause a lot - ;; of GC, so just kill it if it already exists. However, this - ;; makes window management more difficult, so it'd be preferable - ;; to avoid this. - (kill-buffer buffer-name)) - (with-current-buffer (get-buffer-create buffer-name) - (org-ql-view-mode) - (taxy-org-ql-view--add-search buffers-or-files - query :sort sort :taxy-keys taxy-keys) - (pop-to-buffer (current-buffer))))) +(cl-defun taxy-org-ql-view + (&rest rest &key name buffer queries from group sort append) + "Show Org QL QUERIES in BUFFER with `taxy-org-ql-view'. +BUFFER may be a buffer, a name of a buffer, or a name of a buffer +to make. + +QUERIES is a list of plists with the following keys: + + :name An optional name for the query. + :from One or a list of buffers/files to search. + :query The `org-ql' query expression. + :sort One or a list of sorting predicates. + :group A group definition. + +GROUP and SORT, if specified, apply to all QUERIES unless a +query specifies its own. + +If APPEND, add QUERIES to BUFFER; otherwise, replace BUFFER's +contents." + (declare (indent defun)) + ;; Silence byte-compiler since we use `symbol-value' for these. + (ignore from group sort append) + (cl-labels ((add-props + ;; NOTE: This mutates. Maybe good, maybe not. + (plist) (dolist (prop '(:name :from :sort :group) plist) + (unless (plist-member plist prop) + (setf plist (plist-put plist prop (plist-get rest prop))))))) + (let* ((buffer + (cl-typecase buffer + (buffer buffer) + (string (or (get-buffer buffer) + (get-buffer-create (format "*Taxy Org QL View: %s*" buffer))))))) + (with-current-buffer buffer + (unless append + (kill-all-local-variables) + (let ((inhibit-read-only t)) + (erase-buffer))) + (unless (eq 'taxy-org-ql-view-mode major-mode) + (taxy-org-ql-view-mode)) + (cl-pushnew rest taxy-org-ql-view-args :test #'equal) + (let ((inhibit-read-only t)) + (when name + (save-excursion + (goto-char (point-max)) + (insert (propertize (concat name "\n") 'face 'taxy-org-ql-view-header) "\n"))) + (dolist (query queries) + (setf query (add-props query)) + (apply #'taxy-org-ql-view--add-search query))) + (pop-to-buffer (current-buffer)))))) + +(defun taxy-org-ql-view-refresh () + "Refresh buffer." + (interactive) + (cl-assert (eq 'taxy-org-ql-view-mode major-mode)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (dolist (args (reverse taxy-org-ql-view-args)) + (apply #'taxy-org-ql-view :buffer (current-buffer) :append t + args))) (cl-defun taxy-org-ql-view--add-search - (buffers-or-files query &key taxy-keys sort) + (&key name from query group sort) "Show Org QL QUERY on BUFFERS-OR-FILES with `taxy-org-ql-view'." (declare (indent 1)) (let (format-table column-sizes) @@ -405,23 +518,24 @@ Searches in ELEMENT's buffer." (make-fn (&rest args) (apply #'make-taxy-magit-section :make #'make-fn - :take (taxy-make-take-function taxy-keys taxy-org-ql-view-keys) + :take (taxy-make-take-function group taxy-org-ql-view-keys) :format-fn #'format-item :heading-face-fn #'heading-face :level-indent org-ql-view-level-indent :item-indent org-ql-view-item-indent args))) - (let* ((title (org-ql-view--header-line-format - :buffers-files buffers-or-files - :query query - ;; FIXME: View titles. - )) - (items (org-ql-select buffers-or-files query + (let* ((title (or name + (org-ql-view--header-line-format + :buffers-files from + :query query + ;; FIXME: View titles. + ))) + (items (org-ql-select from query :action 'element-with-markers :sort sort)) (taxy (thread-last (make-fn :name title) - (taxy-fill items))) + (taxy-fill items))) (taxy-magit-section-insert-indent-items nil) format-cons) ;; FIXME: Adding a search overwrites the `header-line-format'. From 160fcfcbea2596d70b9a606f2a30b57af8eb44d2 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sun, 19 Feb 2023 16:52:01 -0600 Subject: [PATCH 19/29] Comment: Add FIXME --- taxy-org-ql-view.el | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index ab1f22f..c7e97ab 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -426,6 +426,12 @@ that order." ;;;; Functions +;; FIXME: Each taxy's items are formatted relative to its own items, +;; so column widths don't account for the width of items in other +;; taxys. This should be fixable, but it will require some thoughtful +;; refactoring, which will probably require a new version of +;; taxy-magit-section. + (cl-defun taxy-org-ql-view (&rest rest &key name buffer queries from group sort append) "Show Org QL QUERIES in BUFFER with `taxy-org-ql-view'. From 83cb43a1b91c5c36ed253debfef9e42c0fde9666 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Mon, 20 Feb 2023 05:21:03 -0600 Subject: [PATCH 20/29] WIP: Root taxy, formatting across all items works --- taxy-org-ql-view.el | 255 +++++++++++++++++++++++++++++++------------- 1 file changed, 181 insertions(+), 74 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index c7e97ab..4225e74 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -422,7 +422,8 @@ that order." (define-derived-mode taxy-org-ql-view-mode magit-section-mode "Org QL View" "TODO: Docstring." ;; For compatibility with Org Agenda commands. - (setq-local org-agenda-type 'search)) + (setq-local org-agenda-type 'search + taxy-org-ql-view-format-table (make-hash-table))) ;;;; Functions @@ -432,6 +433,14 @@ that order." ;; refactoring, which will probably require a new version of ;; taxy-magit-section. +(defvar-local taxy-org-ql-view-taxy nil + "Root taxy.") + +(defvar-local taxy-org-ql-view-format-table nil + ;; Setting the default value to a hash table here doesn't work; it + ;; must be initialized in each buffer manually. + "Format table for all items in view.") + (cl-defun taxy-org-ql-view (&rest rest &key name buffer queries from group sort append) "Show Org QL QUERIES in BUFFER with `taxy-org-ql-view'. @@ -454,55 +463,24 @@ contents." (declare (indent defun)) ;; Silence byte-compiler since we use `symbol-value' for these. (ignore from group sort append) - (cl-labels ((add-props - ;; NOTE: This mutates. Maybe good, maybe not. - (plist) (dolist (prop '(:name :from :sort :group) plist) - (unless (plist-member plist prop) - (setf plist (plist-put plist prop (plist-get rest prop))))))) - (let* ((buffer - (cl-typecase buffer - (buffer buffer) - (string (or (get-buffer buffer) - (get-buffer-create (format "*Taxy Org QL View: %s*" buffer))))))) - (with-current-buffer buffer - (unless append - (kill-all-local-variables) - (let ((inhibit-read-only t)) - (erase-buffer))) - (unless (eq 'taxy-org-ql-view-mode major-mode) - (taxy-org-ql-view-mode)) - (cl-pushnew rest taxy-org-ql-view-args :test #'equal) - (let ((inhibit-read-only t)) - (when name - (save-excursion - (goto-char (point-max)) - (insert (propertize (concat name "\n") 'face 'taxy-org-ql-view-header) "\n"))) - (dolist (query queries) - (setf query (add-props query)) - (apply #'taxy-org-ql-view--add-search query))) - (pop-to-buffer (current-buffer)))))) - -(defun taxy-org-ql-view-refresh () - "Refresh buffer." - (interactive) - (cl-assert (eq 'taxy-org-ql-view-mode major-mode)) - (let ((inhibit-read-only t)) - (erase-buffer)) - (dolist (args (reverse taxy-org-ql-view-args)) - (apply #'taxy-org-ql-view :buffer (current-buffer) :append t - args))) - -(cl-defun taxy-org-ql-view--add-search - (&key name from query group sort) - "Show Org QL QUERY on BUFFERS-OR-FILES with `taxy-org-ql-view'." - (declare (indent 1)) - (let (format-table column-sizes) - (cl-labels ((format-item (item) + (let ((buffer + (cl-typecase buffer + (buffer buffer) + (string (or (get-buffer buffer) + (get-buffer-create (format "*Taxy Org QL View: %s*" buffer)))))) + (instance-taxy (make-taxy-magit-section :name name)) + format-cons column-sizes) + (cl-labels ((add-props + ;; NOTE: This mutates. Maybe good, maybe not. + (plist) (dolist (prop '(:name :from :sort :group) plist) + (unless (plist-member plist prop) + (setf plist (plist-put plist prop (plist-get rest prop)))))) + (format-item (item) ;; For compatibility with Org Agenda, we ;; add the marker property to the whole ;; string (though it only seems to check ;; at BOL). - (let* ((string (gethash item format-table)) + (let* ((string (gethash item taxy-org-ql-view-format-table)) (marker (or (get-text-property 0 :org-hd-marker string) (when-let ((pos (next-single-property-change 0 :org-hd-marker string))) (get-text-property pos :org-hd-marker string))))) @@ -530,34 +508,163 @@ contents." :level-indent org-ql-view-level-indent :item-indent org-ql-view-item-indent args))) - (let* ((title (or name - (org-ql-view--header-line-format - :buffers-files from - :query query - ;; FIXME: View titles. - ))) - (items (org-ql-select from query - :action 'element-with-markers - :sort sort)) - (taxy (thread-last (make-fn - :name title) - (taxy-fill items))) - (taxy-magit-section-insert-indent-items nil) - format-cons) - ;; FIXME: Adding a search overwrites the `header-line-format'. - (setf format-cons (taxy-magit-section-format-items - org-ql-view-columns org-ql-view-column-formatters taxy) - format-table (car format-cons) - column-sizes (cdr format-cons) - header-line-format (taxy-magit-section-format-header - column-sizes org-ql-view-column-formatters)) - (add-face-text-property 0 (length header-line-format) 'org-ql-view-header-line - nil header-line-format) - (let ((inhibit-read-only t)) - (save-excursion - (goto-char (point-max)) - (taxy-magit-section-insert taxy :items 'first - :initial-depth -1))))))) + (with-current-buffer buffer + (unless append + (taxy-org-ql-view-mode) + (setf taxy-org-ql-view-taxy (make-taxy-magit-section + :name (propertize (buffer-name buffer) + 'face 'taxy-org-ql-view-header) + :format-fn #'format-item))) + (cl-pushnew rest taxy-org-ql-view-args :test #'equal) + (pcase-dolist ((map (:name this-name) (:from this-from) + (:group this-group) (:sort this-sort) + :query) + queries) + (setf this-name (or this-name name) + this-from (or this-from from) + this-group (or this-group group) + ;; HACK: This binding is ugly. + group this-group + this-sort (or this-sort sort)) + (let* ((title (or this-name + (org-ql-view--header-line-format + :buffers-files from + :query query + ;; FIXME: View titles. + ))) + (items (org-ql-select from query + :action 'element-with-markers + :sort sort)) + (taxy (thread-last (make-fn + :name title) + (taxy-fill items)))) + (push taxy (taxy-taxys instance-taxy)))) + (setf (taxy-taxys instance-taxy) (nreverse (taxy-taxys instance-taxy)) + (taxy-taxys taxy-org-ql-view-taxy) (append (taxy-taxys taxy-org-ql-view-taxy) (list instance-taxy))) + (let ((inhibit-read-only t) + (taxy-magit-section-insert-indent-items nil)) + (erase-buffer) + (setf format-cons (taxy-org-ql-view-magit-section-format-items + org-ql-view-columns org-ql-view-column-formatters taxy-org-ql-view-taxy + :table taxy-org-ql-view-format-table) + ;; taxy-org-ql-view-format-table (car format-cons) + column-sizes (cdr format-cons) + header-line-format (taxy-magit-section-format-header + column-sizes org-ql-view-column-formatters)) + (add-face-text-property 0 (length header-line-format) 'org-ql-view-header-line + nil header-line-format) + (taxy-magit-section-insert taxy-org-ql-view-taxy :items 'first + :initial-depth -1) + (goto-char (point-min))) + (pop-to-buffer (current-buffer)))))) + +(defun taxy-org-ql-view-refresh () + "Refresh buffer." + (interactive) + (cl-assert (eq 'taxy-org-ql-view-mode major-mode)) + (let ((args taxy-org-ql-view-args) + (pos (point)) + (append)) + (dolist (args (reverse args)) + (apply #'taxy-org-ql-view :buffer (current-buffer) :append append + args) + (setf append t)) + (goto-char pos))) + +(cl-defun taxy-org-ql-view-magit-section-format-items + (columns formatters taxy + &key (table (make-hash-table))) + ;; TODO: Add :table argument to `taxy-magit-section-format-items' and release new version. + "Return a cons (table . column-sizes) for COLUMNS, FORMATTERS, and TAXY. +COLUMNS is a list of column names, each of which should have an +associated formatting function in FORMATTERS. + +Table is a hash table keyed by item whose values are display +strings. Column-sizes is an alist whose keys are column names +and values are the column width. Each string is formatted +according to `columns' and takes into account the width of all +the items' values for each column." + (let (column-aligns column-sizes image-p) + (cl-labels ((string-width* + (string) (if-let (pos (text-property-not-all 0 (length string) + 'display nil string)) + ;; Text has a display property: check for an image. + (pcase (get-text-property pos 'display string) + ((and `(image . ,_rest) spec) + ;; An image: try to calcuate the display width. (See also: + ;; `org-string-width'.) + + ;; FIXME: The entire string may not be an image, so the + ;; image part needs to be handled separately from any + ;; non-image part. + + ;; TODO: Do we need to specify the frame? What if the + ;; buffer isn't currently displayed? + (setf image-p t) + (floor (car (image-size spec)))) + (_ + ;; No image: just use `string-width'. + (setf image-p nil) + (string-width string))) + ;; No display property. + (setf image-p nil) + (string-width string))) + (resize-image-string + (string width) (let ((image + (get-text-property + (text-property-not-all 0 (length string) + 'display nil string) + 'display string))) + (propertize (make-string width ? ) 'display image))) + + (format-column + (item depth column-name) + (let* ((column-alist (alist-get column-name formatters nil nil #'equal)) + (fn (alist-get 'formatter column-alist)) + (value (funcall fn item depth)) + (current-column-size (or (map-elt column-sizes column-name) (string-width column-name)))) + (setf (map-elt column-sizes column-name) + (max current-column-size (string-width* value))) + (setf (map-elt column-aligns column-name) + (or (alist-get 'align column-alist) + 'left)) + (when image-p + ;; String probably is an image: set its non-image string value to a + ;; number of matching spaces. It's not always pixel-perfect, but + ;; this is probably as good as we can do without using pixel-based + ;; :align-to's for everything (which might be worth doing in the + ;; future). + + ;; FIXME: This only works properly if the entire string has an image + ;; display property (but this is good enough for now). + (setf value (resize-image-string value (string-width* value)))) + value)) + (format-item + (depth item) (puthash item + (cl-loop for column in columns + collect (format-column item depth column)) + table)) + (format-taxy (depth taxy) + (dolist (item (taxy-items taxy)) + (format-item depth item)) + (dolist (taxy (taxy-taxys taxy)) + (format-taxy (1+ depth) taxy)))) + (format-taxy 0 taxy) + ;; Now format each item's string using the column sizes. + (let* ((column-sizes (nreverse column-sizes)) + (format-string + (string-join + (cl-loop for (name . size) in column-sizes + for align = (pcase-exhaustive (alist-get name column-aligns nil nil #'equal) + ((or `nil 'left) "-") + ('right "")) + collect (format "%%%s%ss" align size)) + " "))) + (maphash (lambda (item column-values) + (puthash item (apply #'format format-string column-values) + table)) + table) + (cons table column-sizes))))) ;;;; Footer From 72b9101e858c7a6162401359764a32268c369876 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Mon, 20 Feb 2023 05:50:40 -0600 Subject: [PATCH 21/29] WIP: Another column, and :columns --- taxy-org-ql-view.el | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 4225e74..573ce89 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -99,6 +99,10 @@ Inherited by level-specific faces.") :background ,(face-background 'header-line)))) "Level-2 group headings.") +(defface org-ql-view-parent-heading + `((t (:inherit font-lock-comment-face))) + "Parent headings (shown in \"Heading\\Parent\" column).") + ;;;;; Columns (eval-and-compile @@ -124,6 +128,20 @@ Inherited by level-specific faces.") :raw-value (org-ql-view--add-faces item))) :org-hd-marker (org-element-property :org-hd-marker item))) +(org-ql-view-define-column "Heading\\Parent" (:max-width 60) + (let* ((marker (org-element-property :org-hd-marker item)) + (parent-heading (org-with-point-at marker + (if (org-up-heading-safe) + (propertize (concat "\\" (org-link-display-format + (nth 4 (org-heading-components)))) + 'face 'org-ql-view-parent-heading) + ""))) + (this-heading (org-link-display-format + (org-element-property + :raw-value (org-ql-view--add-faces item)))) + (string (concat this-heading parent-heading))) + (propertize string :org-hd-marker marker))) + (org-ql-view-define-column "Pri" (:max-width nil) (or (-some->> (org-element-property :priority item) (char-to-string) @@ -162,7 +180,8 @@ Inherited by level-specific faces.") (unless org-ql-view-columns (setq-default org-ql-view-columns - (get 'org-ql-view-columns 'standard-value))) + ;; HACK: + (remove "Heading\\Parent" (get 'org-ql-view-columns 'standard-value)))) ;;;; Taxy keys @@ -442,7 +461,7 @@ that order." "Format table for all items in view.") (cl-defun taxy-org-ql-view - (&rest rest &key name buffer queries from group sort append) + (&rest rest &key name buffer queries from group sort append columns) "Show Org QL QUERIES in BUFFER with `taxy-org-ql-view'. BUFFER may be a buffer, a name of a buffer, or a name of a buffer to make. @@ -516,6 +535,8 @@ contents." 'face 'taxy-org-ql-view-header) :format-fn #'format-item))) (cl-pushnew rest taxy-org-ql-view-args :test #'equal) + (when columns + (setq-local org-ql-view-columns columns)) (pcase-dolist ((map (:name this-name) (:from this-from) (:group this-group) (:sort this-sort) :query) From 017d8c9bcfd357d0b7c6e5566b8801411f921491 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Mon, 20 Feb 2023 05:56:12 -0600 Subject: [PATCH 22/29] Remove duplicate tags --- taxy-org-ql-view.el | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 573ce89..1ace158 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -166,10 +166,11 @@ Inherited by level-specific faces.") (with-current-buffer (marker-buffer marker) (org-with-wide-buffer (goto-char marker) - (cl-loop for type in (org-ql--tags-at marker) - unless (or (eq 'org-ql-nil type) - (not type)) - append type))) + (delete-dups + (cl-loop for type in (org-ql--tags-at marker) + unless (or (eq 'org-ql-nil type) + (not type)) + append type)))) ;; No marker found ;; TODO: Use `display-warning' with `org-ql' as the type. (warn "No marker found for item: %s" item) From d242d9c41f7ef5bb2e9e0215c0b778e62e718abe Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Mon, 20 Feb 2023 06:44:06 -0600 Subject: [PATCH 23/29] WIP: Add taxy-org-ql-view-multi, fix bugs --- taxy-org-ql-view.el | 33 ++++++++++++++++++++++++++------- 1 file changed, 26 insertions(+), 7 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 1ace158..81b3ada 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -373,7 +373,7 @@ that order." (setf args (append (cl-subseq args 0 pos) (cl-subseq args (+ 2 pos)))))) (pcase args - (`(,(or 'nil 't)) (or name "Planned")) + ((or 'nil 't) (or name "Planned")) (_ (let ((element-ts (ts-parse-org-element planned-element))) (pcase args ((and `(:past) @@ -489,7 +489,8 @@ contents." (string (or (get-buffer buffer) (get-buffer-create (format "*Taxy Org QL View: %s*" buffer)))))) (instance-taxy (make-taxy-magit-section :name name)) - format-cons column-sizes) + format-cons column-sizes + make-fn-group) (cl-labels ((add-props ;; NOTE: This mutates. Maybe good, maybe not. (plist) (dolist (prop '(:name :from :sort :group) plist) @@ -522,7 +523,8 @@ contents." (make-fn (&rest args) (apply #'make-taxy-magit-section :make #'make-fn - :take (taxy-make-take-function group taxy-org-ql-view-keys) + ;; FIXME: The binding of `make-fn-group' here is very awkward. See below. + :take (taxy-make-take-function make-fn-group taxy-org-ql-view-keys) :format-fn #'format-item :heading-face-fn #'heading-face :level-indent org-ql-view-level-indent @@ -545,8 +547,12 @@ contents." (setf this-name (or this-name name) this-from (or this-from from) this-group (or this-group group) - ;; HACK: This binding is ugly. - group this-group + ;; FIXME: This binding is ugly, but it seems necessary + ;; due to the way the `make-fn' closes over the + ;; argument passed to `taxy-make-take-function' + ;; (passing it as an argument to `make-fn' does not + ;; work). + make-fn-group (or this-group group) this-sort (or this-sort sort)) (let* ((title (or this-name (org-ql-view--header-line-format @@ -557,8 +563,7 @@ contents." (items (org-ql-select from query :action 'element-with-markers :sort sort)) - (taxy (thread-last (make-fn - :name title) + (taxy (thread-last (make-fn :name title) (taxy-fill items)))) (push taxy (taxy-taxys instance-taxy)))) (setf (taxy-taxys instance-taxy) (nreverse (taxy-taxys instance-taxy)) @@ -580,6 +585,20 @@ contents." (goto-char (point-min))) (pop-to-buffer (current-buffer)))))) +(cl-defun taxy-org-ql-view-multi + (&key buffer from sort group columns sections + &aux append) + (declare (indent defun)) + (pcase-dolist ((map (:name section-name) (:from section-from) + (:sort section-sort) (:group section-group) + :queries) + sections) + (taxy-org-ql-view :buffer buffer :columns columns + :name (or section-name name) :from (or section-from from) + :sort (or section-sort sort) :group (or section-group group) + :queries queries :append append) + (setf append t))) + (defun taxy-org-ql-view-refresh () "Refresh buffer." (interactive) From 194491f57ea6a902b1142cdbae9a8d07ecb57d66 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Tue, 21 Feb 2023 18:04:48 -0600 Subject: [PATCH 24/29] WIP: taxy-org-ql-report, etc --- taxy-org-ql-view.el | 45 +++++++++++++++++++++++---------------------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 81b3ada..c237ab3 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -462,7 +462,7 @@ that order." "Format table for all items in view.") (cl-defun taxy-org-ql-view - (&rest rest &key name buffer queries from group sort append columns) + (&rest rest &key name buffer queries from where group sort append columns) "Show Org QL QUERIES in BUFFER with `taxy-org-ql-view'. BUFFER may be a buffer, a name of a buffer, or a name of a buffer to make. @@ -540,41 +540,40 @@ contents." (cl-pushnew rest taxy-org-ql-view-args :test #'equal) (when columns (setq-local org-ql-view-columns columns)) - (pcase-dolist ((map (:name this-name) (:from this-from) - (:group this-group) (:sort this-sort) + (pcase-dolist ((map (:name query-name) (:from query-from) + (:where query-where) + (:group query-group) (:sort query-sort) :query) queries) - (setf this-name (or this-name name) - this-from (or this-from from) - this-group (or this-group group) - ;; FIXME: This binding is ugly, but it seems necessary + (setf query-name (or query-name name) + query-from (or query-from from) + query-where (or query-where where) + query-group (or query-group group) + ;; FIXME: Query binding is ugly, but it seems necessary ;; due to the way the `make-fn' closes over the ;; argument passed to `taxy-make-take-function' ;; (passing it as an argument to `make-fn' does not ;; work). - make-fn-group (or this-group group) - this-sort (or this-sort sort)) - (let* ((title (or this-name + make-fn-group (or query-group group) + query-sort (or query-sort sort)) + (let* ((title (or query-name (org-ql-view--header-line-format :buffers-files from - :query query - ;; FIXME: View titles. - ))) - (items (org-ql-select from query - :action 'element-with-markers - :sort sort)) + :query query))) + (items (org-ql-query :from query-from :where query-where + :order-by query-sort)) (taxy (thread-last (make-fn :name title) (taxy-fill items)))) (push taxy (taxy-taxys instance-taxy)))) (setf (taxy-taxys instance-taxy) (nreverse (taxy-taxys instance-taxy)) - (taxy-taxys taxy-org-ql-view-taxy) (append (taxy-taxys taxy-org-ql-view-taxy) (list instance-taxy))) + (taxy-taxys taxy-org-ql-view-taxy) (append (taxy-taxys taxy-org-ql-view-taxy) + (list instance-taxy))) (let ((inhibit-read-only t) (taxy-magit-section-insert-indent-items nil)) (erase-buffer) (setf format-cons (taxy-org-ql-view-magit-section-format-items org-ql-view-columns org-ql-view-column-formatters taxy-org-ql-view-taxy :table taxy-org-ql-view-format-table) - ;; taxy-org-ql-view-format-table (car format-cons) column-sizes (cdr format-cons) header-line-format (taxy-magit-section-format-header column-sizes org-ql-view-column-formatters)) @@ -585,18 +584,20 @@ contents." (goto-char (point-min))) (pop-to-buffer (current-buffer)))))) -(cl-defun taxy-org-ql-view-multi - (&key buffer from sort group columns sections +(cl-defun taxy-org-ql-report + (&key buffer queries from where sort group columns sections &aux append) (declare (indent defun)) (pcase-dolist ((map (:name section-name) (:from section-from) + (:where section-where) (:sort section-sort) (:group section-group) - :queries) + (:queries section-queries)) sections) (taxy-org-ql-view :buffer buffer :columns columns :name (or section-name name) :from (or section-from from) + :where (or section-where where) :sort (or section-sort sort) :group (or section-group group) - :queries queries :append append) + :queries (or section-queries queries) :append append) (setf append t))) (defun taxy-org-ql-view-refresh () From 2cd65ea6e0334363322c916719b732a927dcc48d Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Wed, 8 Mar 2023 23:39:44 -0600 Subject: [PATCH 25/29] WIP --- taxy-org-ql-view.el | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index c237ab3..409bf28 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -83,19 +83,20 @@ second levels." "View top-level section names.") (defface org-ql-view-heading - `((t (:inherit magit-section-heading :weight bold))) + `((t (:inherit org-agenda-structure ;; magit-section-heading + :weight bold))) "Group headings. Inherited by level-specific faces.") (defface org-ql-view-heading-1 `((t (:inherit org-ql-view-heading - :height 1.1 :overline t + :height 1.2 :overline t :background ,(face-background 'header-line)))) "Level-1 group headings.") (defface org-ql-view-heading-2 - `((t (:inherit org-ql-view-heading - :height 1.0 :overline nil + `((t (:inherit org-ql-view-heading ;; :inverse-video t + :height 1.1 :overline nil :background ,(face-background 'header-line)))) "Level-2 group headings.") @@ -556,6 +557,8 @@ contents." ;; work). make-fn-group (or query-group group) query-sort (or query-sort sort)) + ;; HACK: Probably not where we really want to add this face. + (add-face-text-property 0 (length query-name) 'org-ql-view-heading-2 nil query-name) (let* ((title (or query-name (org-ql-view--header-line-format :buffers-files from @@ -593,8 +596,11 @@ contents." (:sort section-sort) (:group section-group) (:queries section-queries)) sections) + (setf section-name (or section-name name)) + ;; HACK: Probably not where we really want to add this face. + (add-face-text-property 0 (length section-name) 'org-ql-view-heading-1 nil section-name) (taxy-org-ql-view :buffer buffer :columns columns - :name (or section-name name) :from (or section-from from) + :name section-name :from (or section-from from) :where (or section-where where) :sort (or section-sort sort) :group (or section-group group) :queries (or section-queries queries) :append append) From 4f972547db1f8d3ac68939ba8971d19a79cd12e4 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Fri, 10 Mar 2023 10:45:29 -0600 Subject: [PATCH 26/29] WIP: improvements to dynamic blocks Another idea is to use taxy to output Org plain lists with grouping and indentation, using the column-based formatting in taxy-org-ql-view.el. --- org-ql-search.el | 49 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 13 deletions(-) diff --git a/org-ql-search.el b/org-ql-search.el index b029544..d60bfe4 100644 --- a/org-ql-search.el +++ b/org-ql-search.el @@ -302,40 +302,56 @@ this (must be a single line in the Org buffer): #+BEGIN: org-ql :query (todo \"UNDERWAY\") :columns (priority todo heading) :sort (priority date) :ts-format \"%Y-%m-%d %H:%M\"" - (-let* (((&plist :query :columns :sort :ts-format :take) params) + (-let* (((&plist :query :columns :sort :ts-format :take :from) params) + (from (pcase-exhaustive from + (`nil (current-buffer)) + ((pred listp) from) + ((pred stringp) from) + ('org-directory (org-ql-search-directories-files)))) (query (cl-etypecase query (string (org-ql--query-string-to-sexp query)) (list ;; SAFETY: Query is in sexp form: ask for confirmation, because it could contain arbitrary code. (org-ql--ask-unsafe-query query) query))) - (columns (or columns '(heading todo (priority "P")))) + (columns (or columns '(heading todo (priority "P") planning))) ;; MAYBE: Custom column functions. (format-fns ;; NOTE: Backquoting this alist prevents the lambdas from seeing ;; the variable `ts-format', so we use `list' and `cons'. (list (cons 'todo (lambda (element) (org-element-property :todo-keyword element))) - (cons 'heading (lambda (element) - (let ((normalized-heading - (org-ql-search--link-heading-search-string (org-element-property :raw-value element)))) - (org-ql-search--org-make-link-string normalized-heading (org-link-display-format normalized-heading))))) + (cons 'heading (cl-function + (lambda (element &key (width 100)) + (let ((normalized-heading + (org-ql-search--link-heading-search-string (org-element-property :raw-value element)))) + (org-ql-search--org-make-link-string normalized-heading (s-truncate width (org-link-display-format normalized-heading))))))) (cons 'priority (lambda (element) (--when-let (org-element-property :priority element) (char-to-string it)))) (cons 'deadline (lambda (element) (--when-let (org-element-property :deadline element) - (ts-format ts-format (ts-parse-org-element it))))) + (org-ql-view--format-relative-date (floor (/ (ts-difference (ts-now) (ts-parse-org-element it)) 86400))) + ;; (ts-format ts-format (ts-parse-org-element it)) + ))) (cons 'scheduled (lambda (element) (--when-let (org-element-property :scheduled element) - (ts-format ts-format (ts-parse-org-element it))))) + (org-ql-view--format-relative-date (floor (/ (ts-difference (ts-now) (ts-parse-org-element it)) 86400))) + ;; (ts-format ts-format (ts-parse-org-element it)) + ))) + (cons 'planning (lambda (element) + (--when-let (or (org-element-property :deadline element) + (org-element-property :scheduled element)) + (org-ql-view--format-relative-date (floor (/ (ts-difference (ts-now) (ts-parse-org-element it)) 86400))) + ;; (ts-format ts-format (ts-parse-org-element it)) + ))) (cons 'closed (lambda (element) (--when-let (org-element-property :closed element) (ts-format ts-format (ts-parse-org-element it))))) (cons 'property (lambda (element property) (org-element-property (intern (concat ":" (upcase property))) element))))) - (elements (org-ql-query :from (current-buffer) + (elements (org-ql-query :select 'element-with-markers + :from from :where query - :select '(org-element-headline-parser (line-end-position)) :order-by sort))) (when take (setf elements (cl-etypecase take @@ -348,6 +364,8 @@ this (must be a single line in the Org buffer): (funcall (alist-get column format-fns) element)) (`((,column . ,args) ,_header) (apply (alist-get column format-fns) element args)) + (`(,column . ,(and args (guard (keywordp (car args))))) + (apply (alist-get column format-fns) element args)) (`(,column ,_header) (funcall (alist-get column format-fns) element))) "")) @@ -355,13 +373,18 @@ this (must be a single line in the Org buffer): ;; Table header (insert "| " (string-join (--map (pcase it ((pred symbolp) (capitalize (symbol-name it))) - (`(,_ ,name) name)) + (`(,_ ,name) name) + (`(,name . ,_) (capitalize (symbol-name name)))) columns) " | ") " |" "\n") (insert "|- \n") ; Separator hline - (dolist (element elements) - (insert "| " (format-element element) " |" "\n")) + (let ((org-id-link-to-org-use-id 'use-existing)) + (dolist (element elements) + (let ((link (org-with-point-at (or (org-element-property :org-hd-marker element) + (org-element-property :org-marker element)) + (org-store-link t)))) + (insert "| " (format-element element) " |" "\n")))) (delete-char -1) (org-table-align)))) From 77a4fdb7be932b6ac5fa85faecd2a1ec371758a8 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Tue, 14 Mar 2023 06:53:24 -0500 Subject: [PATCH 27/29] WIP: Taxy-grouped lists of results in dynamic blocks MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Looks like, e.g.: \#+BEGIN: org-ql :from "~/org/main.org" :query "tags:Emacs todo:" :groups (planning todo) :sort (date reverse) :columns (todo heading planning) + Planned + To-do: PROJECT - PROJECT Emacs timers and frames 1640d ago - PROJECT :custom doesn't seem to work with custom setters · Issue #702 · jwiegley/use-package · GitHub 846d ago + To-do: WAITING - WAITING Gnus: gnus-parameter-large-newsgroup-initial-alist ignored? 1704d ago - WAITING byte-compiled functions don't hash consistently 1663d ago - WAITING Change: (org-agenda-bulk-action) Prompt w/number of marked items 1647d ago - WAITING org-link-match struct and functions 1636d ago - WAITING Emacs ~-defun~ macro idea 1296d ago - WAITING Check feedback 801d ago + To-do: UNDERWAY - UNDERWAY Add: By-key memoization by alphapapa · Pull Request #10 · skeeto/emacs-memoize · GitHub 1664d ago - UNDERWAY Setup Git syncing of Org files 1609d ago - UNDERWAY org-zoom-in org-zoom-out 176d ago + To-do: WAITING - WAITING Dash wand/swiss-arrows macros - WAITING Missing Emacs functions - WAITING Org-metaup destructive when region active? - WAITING org creates bibtex fontification buffers without setting dialect, causes error - WAITING =org-map-entries= calls org-agenda-prepare-buffers unnecessarily? - WAITING Improvement to f.el's directory-files function - WAITING Suggestion: Only redraw search buffer after refresh completes · Issue #293 · skeeto/elfeed · GitHub \#+END: --- org-ql-search.el | 75 +++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 64 insertions(+), 11 deletions(-) diff --git a/org-ql-search.el b/org-ql-search.el index d60bfe4..c3e93ff 100644 --- a/org-ql-search.el +++ b/org-ql-search.el @@ -302,7 +302,7 @@ this (must be a single line in the Org buffer): #+BEGIN: org-ql :query (todo \"UNDERWAY\") :columns (priority todo heading) :sort (priority date) :ts-format \"%Y-%m-%d %H:%M\"" - (-let* (((&plist :query :columns :sort :ts-format :take :from) params) + (-let* (((&plist :query :columns :sort :ts-format :take :from :groups) params) (from (pcase-exhaustive from (`nil (current-buffer)) ((pred listp) from) @@ -369,7 +369,20 @@ this (must be a single line in the Org buffer): (`(,column ,_header) (funcall (alist-get column format-fns) element))) "")) - " | "))) + " | ")) + (format-element-list + (element) (string-join (cl-loop for column in columns + collect (or (pcase-exhaustive column + ((pred symbolp) + (funcall (alist-get column format-fns) element)) + (`((,column . ,args) ,_header) + (apply (alist-get column format-fns) element args)) + (`(,column . ,(and args (guard (keywordp (car args))))) + (apply (alist-get column format-fns) element args)) + (`(,column ,_header) + (funcall (alist-get column format-fns) element))) + "")) + " "))) ;; Table header (insert "| " (string-join (--map (pcase it ((pred symbolp) (capitalize (symbol-name it))) @@ -378,15 +391,55 @@ this (must be a single line in the Org buffer): columns) " | ") " |" "\n") - (insert "|- \n") ; Separator hline - (let ((org-id-link-to-org-use-id 'use-existing)) - (dolist (element elements) - (let ((link (org-with-point-at (or (org-element-property :org-hd-marker element) - (org-element-property :org-marker element)) - (org-store-link t)))) - (insert "| " (format-element element) " |" "\n")))) - (delete-char -1) - (org-table-align)))) + ;; (insert "|- \n") + ; Separator hline + (let* ((org-id-link-to-org-use-id 'use-existing)) + ;; (dolist (element elements) + ;; (let ((link (org-with-point-at (or (org-element-property :org-hd-marker element) + ;; (org-element-property :org-marker element)) + ;; (org-store-link t)))) + ;; (insert "| " (format-element element) " |" "\n"))) + (org-ql-dblock-taxy-insert elements :format-fn #'format-element-list :groups groups) + ) + ;; (delete-char -1) + ;; (org-table-align) + ))) + +(cl-defun org-ql-dblock-taxy-insert + (items &key groups (initial-depth 0) + (format-fn (lambda (item) + ;; For compatibility with Org Agenda, we + ;; add the marker property to the whole + ;; string (though it only seems to check + ;; at BOL). + (let* ((string (gethash item taxy-org-ql-view-format-table)) + (marker (or (get-text-property 0 :org-hd-marker string) + (when-let ((pos (next-single-property-change 0 :org-hd-marker string))) + (get-text-property pos :org-hd-marker string))))) + ;; I don't understand why Org sometimes + ;; uses one property and sometimes the + ;; other. + (propertize string + 'org-hd-marker marker + 'org-marker marker))))) + (cl-labels ((make-fn (&rest args) + (apply #'make-taxy + :make #'make-fn + ;; FIXME: The binding of `make-fn-group' here is very awkward. See below. + :take (taxy-make-take-function groups taxy-org-ql-view-keys) + args)) + (insert-taxy (taxy depth) + (insert (make-string (* 2 depth) ? ) "+ " (or (taxy-name taxy) "GROUP") "\n") + (dolist (item (taxy-items taxy)) + (insert-item item (1+ depth))) + (dolist (taxy (taxy-taxys taxy)) + (insert-taxy taxy (1+ depth)))) + (insert-item (item depth) + (insert (make-string (* 2 depth) ? ) "- " (funcall format-fn item) "\n"))) + (let* ((taxy (thread-last (make-fn) + (taxy-fill items)))) + (dolist (taxy (taxy-taxys taxy)) + (insert-taxy taxy initial-depth))))) ;;;; Functions From 7b3bb25fd2226a104681bbc2a3d8510e3a136919 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Wed, 15 Mar 2023 03:42:02 -0500 Subject: [PATCH 28/29] WIP: Add timestamp key, change arg --- taxy-org-ql-view.el | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el index 409bf28..a6c0f2e 100644 --- a/taxy-org-ql-view.el +++ b/taxy-org-ql-view.el @@ -296,7 +296,12 @@ Returns in format \"%Y-%m-%d\"." (org-with-point-at (org-element-property :org-hd-marker item) (concat "Category: " (org-get-category)))) -(defun taxy-org-ql--latest-timestamp-in (regexp element) +(taxy-org-ql-view-define-key timestamp (&key (age 'latest) (format "%Y-%m")) + "FIXME: Docstring" + (when-let (ts (taxy-org-ql--latest-timestamp-in item)) + (ts-format format ts))) + +(cl-defun taxy-org-ql--latest-timestamp-in (element &optional (regexp org-element--timestamp-regexp)) "Return the latest timestamp matching REGEXP in ELEMENT. Searches in ELEMENT's buffer." (org-with-point-at (org-element-property :org-hd-marker element) @@ -311,12 +316,12 @@ Searches in ELEMENT's buffer." (taxy-org-ql-view-define-key ts-year () "Return the year of ITEM's latest timestamp." - (when-let ((latest-ts (taxy-org-ql--latest-timestamp-in org-element--timestamp-regexp item))) + (when-let ((latest-ts (taxy-org-ql--latest-timestamp-in item))) (ts-format "%Y" latest-ts))) (taxy-org-ql-view-define-key ts-month () "Return the month of ITEM's latest timestamp." - (when-let ((latest-ts (taxy-org-ql--latest-timestamp-in org-element--timestamp-regexp item))) + (when-let ((latest-ts (taxy-org-ql--latest-timestamp-in item))) (ts-format "%Y-%m (%B)" latest-ts))) (taxy-org-ql-view-define-key deadline (&rest args) From a441276888d8e8524e86688a8c7d5f08b9421cac Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Wed, 15 Mar 2023 03:42:15 -0500 Subject: [PATCH 29/29] WIP: Add (ts) sorter Probably will do this separately but it's handy in this branch. --- org-ql.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/org-ql.el b/org-ql.el index c0f548a..c9f73fb 100644 --- a/org-ql.el +++ b/org-ql.el @@ -426,7 +426,7 @@ each priority the newest items would appear first." ;; Sort items (pcase sort (`nil items) - ((guard (cl-subsetp (-list sort) '(date deadline scheduled closed todo priority random reverse))) + ((guard (cl-subsetp (-list sort) '(date deadline scheduled closed todo priority random reverse ts))) ;; Default sorting functions (org-ql--sort-by items (-list sort))) ;; Sort by user-given comparator. @@ -2407,6 +2407,10 @@ PREDICATES is a list of one or more sorting methods, including: (apply-partially #'org-ql--date-type< (intern (concat ":" (symbol-name symbol))))) ;; TODO: Rename `date' to `planning'. `date' should be something else. ('date #'org-ql--date<) + (`ts (lambda (a b) + (when-let ((a-ts (taxy-org-ql--latest-timestamp-in a)) + (b-ts (taxy-org-ql--latest-timestamp-in b))) + (ts< a-ts b-ts)))) ('priority #'org-ql--priority<) ('random (lambda (&rest _ignore) (= 0 (random 2))))