diff --git a/org-ql-search.el b/org-ql-search.el index b029544..c3e93ff 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 :groups) 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,22 +364,82 @@ 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))) "")) - " | "))) + " | ")) + (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))) - (`(,_ ,name) name)) + (`(,_ ,name) name) + (`(,name . ,_) (capitalize (symbol-name name)))) columns) " | ") " |" "\n") - (insert "|- \n") ; Separator hline - (dolist (element elements) - (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 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)))) diff --git a/taxy-org-ql-view.el b/taxy-org-ql-view.el new file mode 100644 index 0000000..a6c0f2e --- /dev/null +++ b/taxy-org-ql-view.el @@ -0,0 +1,726 @@ +;;; 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 'cl-lib) +(require 'map) +(require 'seq) + +(require 'org-ql-view) + +(require 'taxy) +(require 'taxy-magit-section) + +;;;; 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 + "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) + +;;;;; 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 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 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.2 :overline t + :background ,(face-background 'header-line)))) + "Level-1 group headings.") + +(defface org-ql-view-heading-2 + `((t (:inherit org-ql-view-heading ;; :inverse-video t + :height 1.1 :overline nil + :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 + (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) + ;; 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)))) + keyword)) + +(org-ql-view-define-column "Heading" (:max-width 60) + (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 "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) + (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) + ;; 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 item) + (org-element-property :org-marker item)))) + (with-current-buffer (marker-buffer marker) + (org-with-wide-buffer + (goto-char marker) + (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) + (org-element-property :tags item)) + (org-element-property :tags item)))) + (org-add-props (concat ":" (string-join tags ":") ":") + nil 'face 'org-tag))) + +(unless org-ql-view-columns + (setq-default org-ql-view-columns + ;; HACK: + (remove "Heading\\Parent" (get 'org-ql-view-columns 'standard-value)))) + +;;;; Taxy keys + +(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.")) + +(taxy-org-ql-view-define-key heading (&rest strings) + "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 ITEM. +If KEYWORD, return whether it matches that." + (when-let ((element-keyword (org-element-property :todo-keyword item))) + (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 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 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 ", ")))))))) + +(taxy-org-ql-view-define-key priority (&optional priority) + "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))) + ;; 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 ITEM's planning-date month, or nil. +Returns in format \"%Y-%m (%B)\"." + (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 ITEM's planning-date year, or nil. +Returns in format \"%Y\"." + (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 ITEM's planning date, or nil. +Returns in format \"%Y-%m-%d\"." + (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 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 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) + (concat "Category: " (org-get-category)))) + +(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) + (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 ITEM's latest timestamp." + (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 item))) + (ts-format "%Y-%m (%B)" latest-ts))) + +(taxy-org-ql-view-define-key deadline (&rest args) + "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)))))))) + +(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 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" #'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) + ;; 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 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 + taxy-org-ql-view-format-table (make-hash-table))) + +;;;; 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. + +(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 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. + +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) + (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 + make-fn-group) + (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 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))) + (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 + ;; 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 + :item-indent org-ql-view-item-indent + args))) + (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) + (when columns + (setq-local org-ql-view-columns columns)) + (pcase-dolist ((map (:name query-name) (:from query-from) + (:where query-where) + (:group query-group) (:sort query-sort) + :query) + queries) + (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 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 + :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))) + (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) + 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)))))) + +(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 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 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) + (setf append t))) + +(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 + +(provide 'taxy-org-ql-view) + +;;; taxy-org-ql-view.el ends here